xapian-bindings/tcl8/generate-tcl-exceptions

   1 # generate-tcl-exceptions: generate error handling code for Tcl bindings
   2 my $copyright = <<'END';
   3  Copyright (c) 2006,2007,2011,2012 Olly Betts
   4
   5  This program is free software; you can redistribute it and/or
   6  modify it under the terms of the GNU General Public License as
   7  published by the Free Software Foundation; either version 2 of the
   8  License, or (at your option) any later version.
   9
  10  This program is distributed in the hope that it will be useful,
  11  but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  GNU General Public License for more details.
  14
  15  You should have received a copy of the GNU General Public License
  16  along with this program; if not, write to the Free Software
  17  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  18 END
  19
  20 use strict;
  21 use exception_data;
  22
  23 open FD, ">except.i" or die $!;
  24
  25 $copyright =~ s/^/ */mg;
  26
  27 print FD <<"EOF";
  28 %{
  29 /** \@file tcl8/except.i
  30  * \@brief Custom Tcl exception handling.
  31  */
  32 /* Warning: This file is generated by $0
  33  * - do not modify directly!
  34  *
  35 $copyright */
  36
  37 EOF
  38
  39 print FD <<'EOF';
  40 #include <exception>
  41
  42 static int XapianTclHandleError(Tcl_Interp * interp, const Xapian::Error &e) {
  43     Tcl_ResetResult(interp);
  44     Tcl_SetErrorCode(interp, "XAPIAN", e.get_type(), NULL);
  45     Tcl_AppendResult(interp, e.get_msg().c_str(), NULL);
  46     return TCL_ERROR;
  47 }
  48
  49 static int XapianTclHandleError(Tcl_Interp * interp, const std::exception &e) {
  50     Tcl_ResetResult(interp);
  51     Tcl_SetErrorCode(interp, "std::exception", NULL);
  52     Tcl_AppendResult(interp, e.what(), NULL);
  53     return TCL_ERROR;
  54 }
  55
  56 static int XapianTclHandleError(Tcl_Interp * interp) {
  57     Tcl_ResetResult(interp);
  58     Tcl_SetErrorCode(interp, "XAPIAN ?", NULL);
  59     Tcl_AppendResult(interp, "Unknown Error", NULL);
  60     return TCL_ERROR;
  61 }
  62
  63 %}
  64
  65 /* Functions and methods which are marked as "nothrow": */
  66 EOF
  67
  68 chdir($INC[0]);
  69 exception_data::for_each_nothrow(sub { print FD "%exception $_[0];\n" });
  70
  71 print FD <<'EOF';
  72
  73 %exception {
  74     try {
  75         $function
  76     } catch (const Xapian::Error &e) {
  77         return XapianTclHandleError(interp, e);
  78     } catch (const std::exception &e) {
  79         return XapianTclHandleError(interp, e);
  80     } catch (...) {
  81         return XapianTclHandleError(interp);
  82     }
  83 }
  84 EOF
  85
  86 close FD or die $!;