vcs.maemo.org Git - pkg-perl/blob - deb-src/libextutils-xspp-perl/libextutils-xspp-perl-0.07/lib/ExtUtils/XSpp/Node.pm

   1 package ExtUtils::XSpp::Node;
   2
   3 =head1 NAME
   4
   5 ExtUtils::XSpp::Node - Base class for the parser output.
   6
   7 =cut
   8
   9 use strict;
  10 use warnings;
  11
  12 sub new {
  13   my $class = shift;
  14   my $this = bless {}, $class;
  15
  16   $this->init( @_ );
  17
  18   return $this;
  19 }
  20
  21 =head2 ExtUtils::XSpp::Node::print
  22
  23 Return a string to be output in the final XS file.
  24 Every class must override this method.
  25
  26 =cut
  27
  28 package ExtUtils::XSpp::Node::Raw;
  29
  30 =head1 ExtUtils::XSpp::Node::Raw
  31
  32 Contains data that should be output "as is" in the destination file.
  33
  34 =cut
  35
  36 use strict;
  37 use base 'ExtUtils::XSpp::Node';
  38
  39 sub init {
  40   my $this = shift;
  41   my %args = @_;
  42
  43   $this->{ROWS} = $args{rows};
  44   push @{$this->{ROWS}}, "\n";
  45 }
  46
  47 =head2 ExtUtils::XSpp::Node::Raw::rows
  48
  49 Returns an array reference holding the rows to be output in the final file.
  50
  51 =cut
  52
  53 sub rows { $_[0]->{ROWS} }
  54 sub print { join( "\n", @{$_[0]->rows} ) . "\n" }
  55
  56 package ExtUtils::XSpp::Node::Comment;
  57
  58 =head1 ExtUtils::XSpp::Node::Comment
  59
  60 Contains data that should be output prefixed with a comment marker
  61
  62 =cut
  63
  64 use strict;
  65 use base 'ExtUtils::XSpp::Node::Raw';
  66
  67 sub init {
  68   my $this = shift;
  69   my %args = @_;
  70
  71   $this->{ROWS} = $args{rows};
  72 }
  73
  74 sub print {
  75   my $this = shift;
  76   my $state = shift;
  77
  78   return "\n";
  79 }
  80
  81 package ExtUtils::XSpp::Node::Package;
  82
  83 =head1 ExtUtils::XSpp::Node::Package
  84
  85 Used to put global functions inside a Perl package.
  86
  87 =cut
  88
  89 use strict;
  90 use base 'ExtUtils::XSpp::Node';
  91
  92 sub init {
  93   my $this = shift;
  94   my %args = @_;
  95
  96   $this->{CPP_NAME} = $args{cpp_name};
  97   $this->{PERL_NAME} = $args{perl_name} || $args{cpp_name};
  98 }
  99
 100 =head2 ExtUtils::XSpp::Node::Package::cpp_name
 101
 102 Returns the C++ name for the package (will be used for namespaces).
 103
 104 =head2 ExtUtils::XSpp::Node::Package::perl_name
 105
 106 Returns the Perl name for the package.
 107
 108 =cut
 109
 110 sub cpp_name { $_[0]->{CPP_NAME} }
 111 sub perl_name { $_[0]->{PERL_NAME} }
 112 sub set_perl_name { $_[0]->{PERL_NAME} = $_[1] }
 113
 114 sub print {
 115   my $this = shift;
 116   my $state = shift;
 117   my $out = '';
 118   my $pcname = $this->perl_name;
 119
 120   if( !defined $state->{current_module} ) {
 121     die "No current module: remember to add a %module{} directive";
 122   }
 123   my $cur_module = $state->{current_module}->to_string;
 124
 125   $out .= <<EOT;
 126
 127 $cur_module PACKAGE=$pcname
 128
 129 EOT
 130
 131   return $out;
 132 }
 133
 134 package ExtUtils::XSpp::Node::Class;
 135
 136 =head1 ExtUtils::XSpp::Node::Class
 137
 138 A class (inherits from Package).
 139
 140 =cut
 141
 142 use strict;
 143 use base 'ExtUtils::XSpp::Node::Package';
 144
 145 sub init {
 146   my $this = shift;
 147   my %args = @_;
 148
 149   $this->SUPER::init( @_ );
 150   $this->{METHODS} = $args{methods} || [];
 151   $this->{BASE_CLASSES} = $args{base_classes} || [];
 152 }
 153
 154 =head2 ExtUtils::XSpp::Node::Class::methods
 155
 156 =cut
 157
 158 sub methods { $_[0]->{METHODS} }
 159 sub base_classes { $_[0]->{BASE_CLASSES} }
 160
 161 sub add_methods {
 162   my $this = shift;
 163   my $access = 'public'; # good enough for now
 164   foreach my $meth ( @_ ) {
 165       if( $meth->isa( 'ExtUtils::XSpp::Node::Method' ) ) {
 166           $meth->{CLASS} = $this;
 167           $meth->{ACCESS} = $access;
 168           $meth->resolve_typemaps;
 169       } elsif( $meth->isa( 'ExtUtils::XSpp::Node::Access' ) ) {
 170           $access = $meth->access;
 171           next;
 172       }
 173       push @{$this->{METHODS}}, $meth;
 174   }
 175 }
 176
 177 sub print {
 178   my $this = shift;
 179   my $state = shift;
 180   my $out = $this->SUPER::print( $state );
 181
 182   foreach my $m ( @{$this->methods} ) {
 183     $out .= $m->print( $state );
 184   }
 185
 186   # add a BOOT block for base classes
 187   if( @{$this->base_classes} ) {
 188       my $class = $this->perl_name;
 189
 190       $out .= <<EOT;
 191 BOOT:
 192     {
 193         AV* isa = get_av( "${class}::ISA", 1 );
 194 EOT
 195
 196     foreach my $b ( @{$this->base_classes} ) {
 197       my $base = $b->perl_name;
 198
 199       $out .= <<EOT;
 200         av_store( isa, 0, newSVpv( "$base", 0 ) );
 201 EOT
 202     }
 203
 204       # close block in BOOT
 205       $out .= <<EOT;
 206     } // blank line here is important
 207
 208 EOT
 209   }
 210
 211   return $out;
 212 }
 213
 214 package ExtUtils::XSpp::Node::Access;
 215
 216 =head1 ExtUtils::XSpp::Node::Access
 217
 218 Access specifier.
 219
 220 =cut
 221
 222 use strict;
 223 use base 'ExtUtils::XSpp::Node';
 224
 225 sub init {
 226   my $this = shift;
 227   my %args = @_;
 228
 229   $this->{ACCESS} = $args{access};
 230 }
 231
 232 sub access { $_[0]->{ACCESS} }
 233
 234 package ExtUtils::XSpp::Node::Function;
 235
 236 use strict;
 237 use base 'ExtUtils::XSpp::Node';
 238
 239 =head1 ExtUtils::XSpp::Node::Function
 240
 241 A function; this is also a base class for C<Method>.
 242
 243 =cut
 244
 245 sub init {
 246   my $this = shift;
 247   my %args = @_;
 248
 249   $this->{CPP_NAME} = $args{cpp_name};
 250   $this->{PERL_NAME} = $args{perl_name} || $args{cpp_name};
 251   $this->{ARGUMENTS} = $args{arguments} || [];
 252   $this->{RET_TYPE} = $args{ret_type};
 253   $this->{CODE} = $args{code};
 254   $this->{CLEANUP} = $args{cleanup};
 255   $this->{POSTCALL} = $args{postcall};
 256   $this->{CLASS} = $args{class};
 257 }
 258
 259 sub resolve_typemaps {
 260   my $this = shift;
 261
 262   if( $this->ret_type ) {
 263     $this->{TYPEMAPS}{RET_TYPE} =
 264       ExtUtils::XSpp::Typemap::get_typemap_for_type( $this->ret_type );
 265   }
 266   foreach my $a ( @{$this->arguments} ) {
 267     my $t = ExtUtils::XSpp::Typemap::get_typemap_for_type( $a->type );
 268     push @{$this->{TYPEMAPS}{ARGUMENTS}}, $t;
 269   }
 270 }
 271
 272 =head2 ExtUtils::XSpp::Node::Function::cpp_name
 273
 274 =head2 ExtUtils::XSpp::Node::Function::perl_name
 275
 276 =head2 ExtUtils::XSpp::Node::Function::arguments
 277
 278 =head2 ExtUtils::XSpp::Node::Function::ret_type
 279
 280 =head2 ExtUtils::XSpp::Node::Function::code
 281
 282 =head2 ExtUtils::XSpp::Node::Function::cleanup
 283
 284 =head2 ExtUtils::XSpp::Node::Function::postcall
 285
 286 =head2 ExtUtils::XSpp::Node::Function::argument_style
 287
 288 Returns either C<ansi> or C<kr>. C<kr> is the default.
 289 C<ansi> is returned if any one of the arguments uses the XS
 290 C<length> feature.
 291
 292 =cut
 293
 294 sub cpp_name { $_[0]->{CPP_NAME} }
 295 sub perl_name { $_[0]->{PERL_NAME} }
 296 sub arguments { $_[0]->{ARGUMENTS} }
 297 sub ret_type { $_[0]->{RET_TYPE} }
 298 sub code { $_[0]->{CODE} }
 299 sub cleanup { $_[0]->{CLEANUP} }
 300 sub postcall { $_[0]->{POSTCALL} }
 301 sub package_static { ( $_[0]->{STATIC} || '' ) eq 'package_static' }
 302 sub class_static { ( $_[0]->{STATIC} || '' ) eq 'class_static' }
 303 sub virtual { $_[0]->{VIRTUAL} }
 304
 305 sub set_perl_name { $_[0]->{PERL_NAME} = $_[1] }
 306 sub set_static { $_[0]->{STATIC} = $_[1] }
 307 sub set_virtual { $_[0]->{VIRTUAL} = $_[1] }
 308
 309 sub argument_style {
 310   my $this = shift;
 311   foreach my $arg (@{$this->{ARGUMENTS}}) {
 312     return 'ansi' if $arg->name =~ /length.*\(/;
 313   }
 314   return 'kr';
 315 }
 316
 317 # Depending on argument style, this produces either: (style=kr)
 318 #
 319 # return_type
 320 # class_name::function_name( args = def, ... )
 321 #     type arg
 322 #     type arg
 323 #   PREINIT:
 324 #     aux vars
 325 #   [PP]CODE:
 326 #     RETVAL = new Foo( THIS->method( arg1, *arg2 ) );
 327 #   POSTCALL:
 328 #     /* anything */
 329 #   OUTPUT:
 330 #     RETVAL
 331 #   CLEANUP:
 332 #     /* anything */
 333 #
 334 # Or: (style=ansi)
 335 #
 336 # return_type
 337 # class_name::function_name( type arg1 = def, type arg2 = def, ... )
 338 #   PREINIT:
 339 # (rest as above)
 340
 341 sub print {
 342   my $this = shift;
 343   my $state = shift;
 344   my $out = '';
 345   my $fname = $this->perl_function_name;
 346   my $args = $this->arguments;
 347   my $ret_type = $this->ret_type;
 348   my $ret_typemap = $this->{TYPEMAPS}{RET_TYPE};
 349   my $need_call_function = 0;
 350   my( $init, $arg_list, $call_arg_list, $code, $output, $cleanup,
 351       $postcall, $precall ) =
 352     ( '', '', '', '', '', '', '', '' );
 353   my $use_ansi_style = $this->argument_style() eq 'ansi';
 354
 355   if( $args && @$args ) {
 356     my $has_self = $this->is_method ? 1 : 0;
 357     my( @arg_list, @call_arg_list );
 358     foreach my $i ( 0 .. $#$args ) {
 359       my $arg = ${$args}[$i];
 360       my $t = $this->{TYPEMAPS}{ARGUMENTS}[$i];
 361       my $pc = $t->precall_code( sprintf( 'ST(%d)', $i + $has_self ),
 362                                  $arg->name );
 363
 364       $need_call_function ||=    defined $t->call_parameter_code( '' )
 365                               || defined $pc;
 366       my $type = $use_ansi_style ? $t->cpp_type . ' ' : '';
 367       push @arg_list, $type . $arg->name . ( $arg->has_default ? ' = ' . $arg->default : '' );
 368       if (!$use_ansi_style) {
 369         $init .= '    ' . $t->cpp_type . ' ' . $arg->name . "\n";
 370       }
 371
 372       my $call_code = $t->call_parameter_code( $arg->name );
 373       push @call_arg_list, defined( $call_code ) ? $call_code : $arg->name;
 374       $precall .= $pc . ";\n" if $pc
 375     }
 376
 377     $arg_list = ' ' . join( ', ', @arg_list ) . ' ';
 378     $call_arg_list = ' ' . join( ', ', @call_arg_list ) . ' ';
 379   }
 380   # same for return value
 381   $need_call_function ||= $ret_typemap &&
 382     ( defined $ret_typemap->call_function_code( '', '' ) ||
 383       defined $ret_typemap->output_code ||
 384       defined $ret_typemap->cleanup_code );
 385   # is C++ name != Perl name?
 386   $need_call_function ||= $this->cpp_name ne $this->perl_name;
 387   # package-static function
 388   $need_call_function ||= $this->package_static;
 389
 390   my $retstr = $ret_typemap ? $ret_typemap->cpp_type : 'void';
 391
 392   # special case: constructors with name different from 'new'
 393   # need to be declared 'static' in XS
 394   if( $this->isa( 'ExtUtils::XSpp::Node::Constructor' ) &&
 395       $this->perl_name ne $this->cpp_name ) {
 396     $retstr = "static $retstr";
 397   }
 398
 399   my $has_ret = $ret_typemap && !$ret_typemap->type->is_void;
 400   if( $need_call_function ) {
 401     my $ccode = $this->_call_code( $call_arg_list );
 402     if( $has_ret && defined $ret_typemap->call_function_code( '', '' ) ) {
 403       $ccode = $ret_typemap->call_function_code( $ccode, 'RETVAL' );
 404     } elsif( $has_ret ) {
 405       $ccode = "RETVAL = $ccode";
 406     }
 407
 408     $code .= "  CODE:\n";
 409     $code .= '    ' . $precall if $precall;
 410     $code .= '    ' . $ccode . ";\n";
 411
 412     if( $has_ret && defined $ret_typemap->output_code ) {
 413       $code .= '    ' . $ret_typemap->output_code . ";\n";
 414     }
 415     $output = "  OUTPUT: RETVAL\n" if $has_ret;
 416
 417     if( $has_ret && defined $ret_typemap->cleanup_code ) {
 418       $cleanup .= "  CLEANUP:\n";
 419       $cleanup .= '    ' . $ret_typemap->cleanup_code . ";\n";
 420     }
 421   }
 422
 423   if( $this->code ) {
 424     $code = "  CODE:\n    " . join( "\n", @{$this->code} ) . "\n";
 425     $output = "  OUTPUT: RETVAL\n" if $code =~ m/RETVAL/;
 426   }
 427   if( $this->postcall ) {
 428     $postcall = "  POSTCALL:\n    " . join( "\n", @{$this->postcall} ) . "\n";
 429     $output ||= "  OUTPUT: RETVAL\n" if $has_ret;
 430   }
 431   if( $this->cleanup ) {
 432     $cleanup ||= "  CLEANUP:\n";
 433     my $clcode = join( "\n", @{$this->cleanup} );
 434     $cleanup .= "    $clcode\n";
 435   }
 436
 437   if( !$this->is_method && $fname =~ /^(.*)::(\w+)$/ ) {
 438     my $pcname = $1;
 439     $fname = $2;
 440     my $cur_module = $state->{current_module}->to_string;
 441     $out .= <<EOT;
 442 $cur_module PACKAGE=$pcname
 443
 444 EOT
 445   }
 446
 447   $out .= "$retstr\n";
 448   $out .= "$fname($arg_list)\n";
 449   $out .= $init;
 450   $out .= $code;
 451   $out .= $postcall;
 452   $out .= $output;
 453   $out .= $cleanup;
 454   $out .= "\n";
 455 }
 456
 457 sub perl_function_name { $_[0]->perl_name }
 458 sub is_method { 0 }
 459
 460 =begin documentation
 461
 462 ExtUtils::XSpp::Node::_call_code( argument_string )
 463
 464 Return something like "foo( $argument_string )".
 465
 466 =end documentation
 467
 468 =cut
 469
 470 sub _call_code { return $_[0]->cpp_name . '(' . $_[1] . ')'; }
 471
 472 package ExtUtils::XSpp::Node::Method;
 473
 474 use strict;
 475 use base 'ExtUtils::XSpp::Node::Function';
 476
 477 sub class { $_[0]->{CLASS} }
 478 sub perl_function_name { $_[0]->class->cpp_name . '::' .
 479                          $_[0]->perl_name }
 480 sub _call_code {
 481     my( $self ) = @_;
 482
 483     if( $self->package_static ) {
 484         return $_[0]->class->cpp_name . '::' .
 485                $_[0]->cpp_name . '(' . $_[1] . ')';
 486     } else {
 487         return "THIS->" .
 488                $_[0]->cpp_name . '(' . $_[1] . ')';
 489     }
 490 }
 491
 492 sub is_method { 1 }
 493
 494 package ExtUtils::XSpp::Node::Constructor;
 495
 496 use strict;
 497 use base 'ExtUtils::XSpp::Node::Method';
 498
 499 sub init {
 500   my $this = shift;
 501   $this->SUPER::init( @_ );
 502
 503   die "Can't specify return value in constructor" if $this->{RET_TYPE};
 504 }
 505
 506 sub ret_type {
 507   my $this = shift;
 508
 509   ExtUtils::XSpp::Node::Type->new( base      => $this->class->cpp_name,
 510                             pointer   => 1 );
 511 }
 512
 513 sub perl_function_name {
 514   my $this = shift;
 515   my( $pname, $cname, $pclass, $cclass ) = ( $this->perl_name,
 516                                              $this->cpp_name,
 517                                              $this->class->perl_name,
 518                                              $this->class->cpp_name );
 519
 520   if( $pname ne $cname ) {
 521     return $cclass . '::' . $pname;
 522   } else {
 523     return $cclass . '::' . 'new';
 524   }
 525 }
 526
 527 sub _call_code { return "new " . $_[0]->class->cpp_name .
 528                    '(' . $_[1] . ')'; }
 529
 530 package ExtUtils::XSpp::Node::Destructor;
 531
 532 use strict;
 533 use base 'ExtUtils::XSpp::Node::Method';
 534
 535 sub init {
 536   my $this = shift;
 537   $this->SUPER::init( @_ );
 538
 539   die "Can't specify return value in destructor" if $this->{RET_TYPE};
 540 }
 541
 542 sub perl_function_name { $_[0]->class->cpp_name . '::' . 'DESTROY' }
 543 sub ret_type { undef }
 544
 545 package ExtUtils::XSpp::Node::Argument;
 546
 547 use strict;
 548 use base 'ExtUtils::XSpp::Node';
 549
 550 sub init {
 551   my $this = shift;
 552   my %args = @_;
 553
 554   $this->{TYPE} = $args{type};
 555   $this->{NAME} = $args{name};
 556   $this->{DEFAULT} = $args{default};
 557 }
 558
 559 sub print {
 560   my $this = shift;
 561   my $state = shift;
 562
 563   return join( ' ',
 564                $this->type->print( $state ),
 565                $this->name,
 566                ( $this->default ?
 567                  ( '=', $this->default ) : () ) );
 568 }
 569
 570 sub type { $_[0]->{TYPE} }
 571 sub name { $_[0]->{NAME} }
 572 sub default { $_[0]->{DEFAULT} }
 573 sub has_default { defined $_[0]->{DEFAULT} }
 574
 575 package ExtUtils::XSpp::Node::Type;
 576
 577 use strict;
 578 use base 'ExtUtils::XSpp::Node';
 579
 580 # normalized names for some integral C types
 581 my %normalize =
 582   ( 'unsigned'           => 'unsigned int',
 583     'long int'           => 'long',
 584     'unsigned long int'  => 'unsigned long',
 585     'short int'          => 'short',
 586     'unsigned short int' => 'unsigned short',
 587     );
 588
 589 sub init {
 590   my $this = shift;
 591   my %args = @_;
 592
 593   $this->{BASE} = $normalize{$args{base}} || $args{base};
 594   $this->{POINTER} = $args{pointer} ? 1 : 0;
 595   $this->{REFERENCE} = $args{reference} ? 1 : 0;
 596   $this->{CONST} = $args{const} ? 1 : 0;
 597   $this->{TEMPLATE_ARGS} = $args{template_args} || [];
 598 }
 599
 600 sub is_const { $_[0]->{CONST} }
 601 sub is_reference { $_[0]->{REFERENCE} }
 602 sub is_pointer { $_[0]->{POINTER} }
 603 sub base_type { $_[0]->{BASE} }
 604 sub template_args { $_[0]->{TEMPLATE_ARGS} }
 605
 606 sub equals {
 607   my( $f, $s ) = @_;
 608
 609   return 0 if @{$f->template_args} != @{$s->template_args};
 610
 611   for( my $i = 0; $i < @{$f->template_args}; ++$i ) {
 612       return 0
 613           unless $f->template_args->[$i]->equals( $s->template_args->[$i] );
 614   }
 615
 616   return $f->is_const == $s->is_const
 617       && $f->is_reference == $s->is_reference
 618       && $f->is_pointer == $s->is_pointer
 619       && $f->base_type eq $s->base_type;
 620 }
 621
 622 sub is_void { return $_[0]->base_type eq 'void' &&
 623                 !$_[0]->is_pointer && !$_[0]->is_reference }
 624
 625 sub print_tmpl_args {
 626   my $this = shift;
 627   my $state = shift;
 628   my $tmpl_args = '';
 629   if( @{$this->template_args} ) {
 630       $tmpl_args =   '< '
 631                    . join( ', ',
 632                            map $_->print( $state ), @{$this->template_args} )
 633                    . ' >';
 634   }
 635   return $tmpl_args;
 636 }
 637
 638 sub print {
 639   my $this = shift;
 640   my $state = shift;
 641
 642   return join( '',
 643                ( $this->is_const ? 'const ' : '' ),
 644                $this->base_type,
 645                $this->print_tmpl_args,
 646                ( $this->is_pointer ? ( '*' x $this->is_pointer ) :
 647                  $this->is_reference ? '&' : '' ) );
 648 }
 649
 650
 651 package ExtUtils::XSpp::Node::Module;
 652
 653 use strict;
 654 use base 'ExtUtils::XSpp::Node';
 655
 656 sub init {
 657   my $this = shift;
 658   my %args = @_;
 659
 660   $this->{MODULE} = $args{module};
 661 }
 662
 663 sub module { $_[0]->{MODULE} }
 664 sub to_string { 'MODULE=' . $_[0]->module }
 665 sub print { return $_[0]->to_string . "\n" }
 666
 667 package ExtUtils::XSpp::Node::File;
 668
 669 use strict;
 670 use base 'ExtUtils::XSpp::Node';
 671
 672 sub init {
 673   my $this = shift;
 674   my %args = @_;
 675
 676   $this->{FILE} = $args{file};
 677 }
 678
 679 sub file { $_[0]->{FILE} }
 680 sub print { "\n" }
 681
 682 1;