1 | package ARB; |
---|
2 | |
---|
3 | use strict; |
---|
4 | use vars qw($VERSION @ISA @EXPORT); |
---|
5 | |
---|
6 | require Exporter; |
---|
7 | require DynaLoader; |
---|
8 | |
---|
9 | @ISA = qw(Exporter DynaLoader); |
---|
10 | # Items to export into callers namespace by default. Note: do not export |
---|
11 | # names by default without a very good reason. Use EXPORT_OK instead. |
---|
12 | # Do not simply export all your public functions/methods/constants. |
---|
13 | @EXPORT = qw( |
---|
14 | set_inGlobalEvalState |
---|
15 | ); |
---|
16 | $VERSION = '0.01'; |
---|
17 | |
---|
18 | bootstrap ARB $VERSION; |
---|
19 | |
---|
20 | # globally catch die, redirect to arb_message, then confess |
---|
21 | package CORE::GLOBAL; |
---|
22 | use subs 'die'; |
---|
23 | my $already_dying = 0; |
---|
24 | my $in_global_eval = 0; # hack to make eval-based perl-scripts work with die-catcher (below). |
---|
25 | |
---|
26 | sub ARB::set_inGlobalEvalState($) { |
---|
27 | # if your script uses eval, protect the top-level eval as follows: |
---|
28 | # |
---|
29 | # eval { |
---|
30 | # set_inGlobalEvalState(1); |
---|
31 | # do_something_that_may_die(); |
---|
32 | # }; |
---|
33 | # set_inGlobalEvalState(0); |
---|
34 | # if ($@) { die $@; } # this call of die will trigger prepare_to_die() below. |
---|
35 | # |
---|
36 | my ($state) = @_; |
---|
37 | $in_global_eval = $state; |
---|
38 | } |
---|
39 | |
---|
40 | sub show_arb_message($) { |
---|
41 | my ($msg) = @_; |
---|
42 | $msg =~ s/\n/\\n/g; |
---|
43 | $msg =~ s/'/"/g; |
---|
44 | system("arb_message '$msg'"); |
---|
45 | } |
---|
46 | |
---|
47 | sub die { |
---|
48 | if ($already_dying==0 and $in_global_eval==0) { |
---|
49 | $already_dying++; # do not recurse |
---|
50 | |
---|
51 | ARB::prepare_to_die(); # abort all transactions and close all databases (too avoid deadlock; see #603) |
---|
52 | |
---|
53 | my ($msg) = @_; |
---|
54 | $msg =~ s/\n+$//g; # remove trailing LFs |
---|
55 | my $errname = 'arb macro/perl execution error'; |
---|
56 | if ($msg eq '') { $msg = 'unknown '.$errname; } |
---|
57 | else { $msg = "$errname: '$msg'"; } |
---|
58 | show_arb_message($msg."\n(see console for details)"); |
---|
59 | |
---|
60 | use Carp; |
---|
61 | Carp::confess("$msg"); # recurses into this sub |
---|
62 | } |
---|
63 | else { |
---|
64 | CORE::die @_; |
---|
65 | } |
---|
66 | } |
---|
67 | |
---|
68 | # Preloaded methods go here. |
---|
69 | |
---|
70 | # Autoload methods go after =cut, and are processed by the autosplit program. |
---|
71 | |
---|
72 | 1; |
---|
73 | __END__ |
---|
74 | # Below is the stub of documentation for your module. You better edit it! |
---|
75 | |
---|
76 | =head1 NAME |
---|
77 | |
---|
78 | ARB - Perl extension for ARB |
---|
79 | |
---|
80 | =head1 SYNOPSIS |
---|
81 | |
---|
82 | use ARB; |
---|
83 | |
---|
84 | =head1 DESCRIPTION |
---|
85 | |
---|
86 | The ARB perl module provides access to a ARB databases. You may |
---|
87 | connect to a remote database (e.g. a running instance of ARB_NTREE) or |
---|
88 | open your own database. |
---|
89 | |
---|
90 | =head1 AUTHOR |
---|
91 | |
---|
92 | ARB development, devel@arb-home.de |
---|
93 | |
---|
94 | =head1 SEE ALSO |
---|
95 | |
---|
96 | perl(1). |
---|
97 | |
---|
98 | =cut |
---|