search-xapian/generate-perl-exceptions

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 # Author: Andreas Marienborg <andreas.marienborg@gmail.com>
   5 # Donated as is to xapian project. Use and modify as see fit
   6
   7 BEGIN {
   8     my $dir = shift || '.';
   9     if ($dir eq '--help') {
  10         print "Syntax: $0 [<path to srcdir> [<xapian version>]\n\n";
  11         print "This script needs to know the source directory to find\n";
  12         print "exception_data.pm - by default it looks in '.'.\n";
  13         exit 0;
  14     }
  15     push(@INC, $dir);
  16
  17     $::version = shift || '';
  18     if ($::version =~ /^(\d+)\.(\d+)\,(\d+)/) {
  19         $::version = $1 * 1000000 + $2 * 1000 + $3;
  20     } else {
  21         # Assume 1.4.x if not specified.
  22         $::version = 1004000;
  23     }
  24 }
  25
  26 # We load the exception data from xapian-core.
  27 use exception_data qw(@baseclasses @classes %subclasses);
  28
  29 # Generate typemaps for Xapian::Error and its subclasses.
  30 my $tm = "typemap-errorclasses";
  31 open(TM, ">", "$tm.tmp")
  32     or die "cannot write '$tm.tmp': $!\n";
  33
  34 foreach (@baseclasses, @classes) {
  35     my ($classname, $parent, $desc) = split /\t/;
  36     print TM "$classname\tO_OBJECT\n";
  37     print TM "$classname *\tO_OBJECT\n";
  38 }
  39 close TM;
  40
  41 rename "$tm.tmp", $tm
  42     or die "Failed to rename '$tm.tmp' to '$tm': $!\n";
  43
  44 my $fnm = "Xapian/Error.pm";
  45 open F, '>', "$fnm.tmp" or die $!;
  46
  47 print F <<'END';
  48 package Search::Xapian::Error;
  49
  50 =head1 NAME
  51
  52 Search::Xapian::Error - Base class for all exceptions in Search::Xapian
  53
  54 =head1 DESCRIPTION
  55
  56 This is an abstract class in C++, i.e. it cannot be instantiated directly.
  57 In Perl there is no such concept, but you should not need to create instances
  58 of this class yourself.
  59
  60 =head1 METHODS
  61
  62 All exception objects have the following methods
  63
  64 =head2 get_msg
  65
  66 Returns a string with a descriptive error message, useful for outputting
  67
  68 =head2 get_type
  69
  70 The type of this error (e.g. "DocNotFoundError").
  71
  72 =head2 get_context
  73
  74 Optional context information, returned as a string
  75
  76 =head2 get_error_string
  77
  78 Returns any error string from errno or similar associated with this error
  79
  80 =cut
  81
  82 use 5.006;
  83 use strict;
  84 use warnings;
  85
  86 require DynaLoader;
  87
  88 END
  89
  90 foreach my $subclass (@{$subclasses{'Error'}}) {
  91     print F "use Search::Xapian::$subclass;\n";
  92 }
  93
  94 print F <<'END';
  95
  96 our @ISA = qw(DynaLoader);
  97
  98 # Preloaded methods go here.
  99
 100 # In a new thread, copy objects of this class to unblessed, undef values.
 101 sub CLONE_SKIP { 1 }
 102
 103 sub new {
 104     my $class = shift;
 105     my ($self);
 106     bless $self, $class;
 107
 108     return $self;
 109 }
 110
 111 1;
 112 END
 113
 114 close F or die $!;
 115 rename "$fnm.tmp", "$fnm" or die $!;
 116
 117 foreach ('Error', @baseclasses, @classes) {
 118     my ($classname, $parent, $full_description) = split /\t/;
 119
 120     # XS/CLASSNAME.xs
 121     $fnm = "XS/$classname.xs";
 122     open F, '>', "$fnm.tmp" or die $!;
 123
 124     print F <<"END";
 125 MODULE = Search::Xapian\t PACKAGE = Search::Xapian::$classname
 126
 127 PROTOTYPES: ENABLE
 128
 129 string
 130 ${classname}::get_type()
 131
 132 string
 133 ${classname}::get_msg()
 134
 135 string
 136 ${classname}::get_context()
 137
 138 const char *
 139 ${classname}::get_error_string()
 140
 141 void
 142 ${classname}::DESTROY()
 143 END
 144
 145     if (exists $subclasses{$classname}) {
 146         print F "\n";
 147         foreach my $subclass (@{$subclasses{$classname}}) {
 148             print F "INCLUDE: XS/$subclass.xs\n";
 149         }
 150     }
 151
 152     close F or die $!;
 153     rename "$fnm.tmp", "$fnm" or die $!;
 154
 155     next if $classname eq 'Error';
 156
 157     $full_description =~ s!^[/ ]\*[*/]?!!mg;
 158     $full_description =~ s!\*\/$!!mg; # ! to unconfuse vim
 159
 160     my ($heading, $desc) = split('\n\n', $full_description, 2);
 161     $desc ||= '';
 162
 163     # Xapian/CLASSNAME.pm
 164     $fnm = "Xapian/$classname.pm";
 165     open F, '>', "$fnm.tmp" or die $!;
 166
 167     print F <<"END";
 168 package Search::Xapian::$classname;
 169
 170 =head1 NAME
 171
 172 Search::Xapian::$classname - $heading
 173
 174 =head1 DESCRIPTION
 175
 176 $desc
 177 =cut
 178
 179 use 5.006;
 180 use strict;
 181 use warnings;
 182
 183 require DynaLoader;
 184
 185 # For compatibility with XS Search::Xapian < 1.2.3 which still threw strings
 186 # in some cases.
 187 use overload '""' => sub { "Exception: ".\$_[0]->get_msg };
 188
 189 END
 190
 191     if (exists $subclasses{$classname}) {
 192         foreach my $subclass (@{$subclasses{$classname}}) {
 193             print F "use Search::Xapian::$subclass;\n";
 194         }
 195         print F "\n";
 196     }
 197
 198     print F <<"END";
 199 our \@ISA = qw(DynaLoader Search::Xapian::$parent);
 200
 201 1;
 202 END
 203
 204     close F or die $!;
 205     rename "$fnm.tmp", "$fnm" or die $!;
 206 }
 207
 208 # write new handle_exception.cc
 209
 210 $fnm = "handle_exception.cc";
 211 open F, '>', "$fnm.tmp" or die $!;
 212
 213 print F <<'END';
 214 #include <xapian.h>
 215
 216 extern "C" {
 217 #include "EXTERN.h"
 218 #include "perl.h"
 219 #include "XSUB.h"
 220 }
 221
 222 /* handle_exception function
 223  *
 224  * called in catch blocks to croak or rethrow in perl land
 225  */
 226
 227 void handle_exception(void) {
 228     try {
 229         throw;
 230 END
 231
 232 foreach (reverse @classes) {
 233     my ($classname, $parent, $full_description) = split /\t/;
 234
 235     print F <<"END";
 236     } catch (const Xapian::$classname & error) {
 237         SV * errsv = get_sv("\@", TRUE);
 238         sv_setref_pv(errsv, "Search::Xapian::$classname", (void *) new Xapian::$classname(error));
 239         croak(Nullch);
 240 END
 241 }
 242
 243 print F <<'END';
 244     } catch (const std::exception & error) {
 245         croak( "std::exception: %s", error.what());
 246     } catch (...) {
 247         croak("something terrible happened");
 248     }
 249 }
 250 END
 251
 252 close F or die $!;
 253 rename "$fnm.tmp", "$fnm" or die $!;