1# Copyright 2014-2019 Free Software Foundation, Inc.
2#
3# This program is free software; you can redistribute it and/or modify
4# it under the terms of the GNU General Public License as published by
5# the Free Software Foundation; either version 3 of the License,
6# or (at your option) any later version.
7#
8# This program is distributed in the hope that it will be useful,
9# but WITHOUT ANY WARRANTY; without even the implied warranty of
10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11# GNU General Public License for more details.
12#
13# You should have received a copy of the GNU General Public License
14# along with this program.  If not, see <http://www.gnu.org/licenses/>.
15
16package Texinfo::XSLoader;
17
18use DynaLoader;
19
20use 5.00405;
21use strict;
22use warnings;
23
24our $TEXINFO_XS;
25
26our $VERSION = '6.8';
27
28our $disable_XS;
29
30# For verbose information about what's being done
31sub _debug($) {
32  if ($TEXINFO_XS eq 'debug') {
33    my $msg = shift;
34    warn $msg . "\n";
35  }
36}
37
38# For messages to say that XS module couldn't be loaded
39sub _fatal($) {
40  if ($TEXINFO_XS eq 'debug'
41      or $TEXINFO_XS eq 'required'
42      or $TEXINFO_XS eq 'warn') {
43    my $msg = shift;
44    warn $msg . "\n";
45  }
46}
47
48# We look for the .la and .so files in @INC because this allows us to override
49# which modules are used using -I flags to "perl".
50sub _find_file($) {
51  my $file = shift;
52  for my $dir (@INC) {
53    next if ref($dir);
54    _debug "checking $dir/$file";
55    if (-f "$dir/$file") {
56      _debug "found $dir/$file";
57      return ($dir, "$dir/$file");
58    }
59  }
60  return undef;
61}
62
63# Load either from XS implementation in $MODULE along with Perl file
64# $PERL_EXTRA_FILE, or non-XS implementation $FALLBACK_MODULE.
65# $MODULE_NAME is the name of a Libtool file used for
66# loading the XS subroutines.
67# $INTERFACE_VERSION is a module interface number, to be changed when the XS
68# interface changes.
69sub init {
70 my ($module,
71     $fallback_module,
72     $module_name,
73     $perl_extra_file,
74     $interface_version,
75     $warning_message,
76     $fatal_message
77   ) = @_;
78
79 # Possible values for TEXINFO_XS environment variable:
80 #
81 # TEXINFO_XS=omit         # don't try loading xs at all
82 # TEXINFO_XS=default      # try xs, libtool, silent fallback
83 # TEXINFO_XS=warn         # try xs, libtool warn on failure
84 # TEXINFO_XS=required     # abort if not loadable, no fallback
85 # TEXINFO_XS=debug        # voluminuous debugging
86 #
87 # Other values are treated at the moment as 'default'.
88
89 $TEXINFO_XS = $ENV{'TEXINFO_XS'};
90 if (!defined($TEXINFO_XS)) {
91   $TEXINFO_XS = '';
92 }
93
94 if ($TEXINFO_XS eq 'omit') {
95   # Don't try to use the XS module
96   goto FALLBACK;
97 }
98
99 if ($disable_XS) {
100   _fatal "use of XS modules was disabled when Texinfo was built";
101   goto FALLBACK;
102 }
103
104 if ($warning_message) {
105   _debug $warning_message;
106 }
107
108 if ($fatal_message) {
109   _fatal $fatal_message;
110   goto FALLBACK;
111 }
112
113 if (!$module) {
114   goto FALLBACK;
115 }
116
117 my ($libtool_dir, $libtool_archive) = _find_file("$module_name.la");
118 if (!$libtool_archive) {
119   if ($TEXINFO_XS eq 'libtool') {
120     _fatal "$module_name: couldn't find Libtool archive file";
121     goto FALLBACK;
122   }
123   _debug "$module_name: couldn't find Libtool archive file";
124   goto FALLBACK;
125 }
126
127 my $dlname = undef;
128 my $dlpath = undef;
129
130 my $fh;
131 open $fh, $libtool_archive;
132 if (!$fh) {
133   _fatal "$module_name: couldn't open Libtool archive file";
134   goto FALLBACK;
135 }
136
137 # Look for the line in XS*.la giving the name of the loadable object.
138 while (my $line = <$fh>) {
139   if ($line =~ /^\s*dlname\s*=\s*'([^']+)'\s$/) {
140     $dlname = $1;
141     last;
142   }
143 }
144 if (!$dlname) {
145   _fatal "$module_name: couldn't find name of shared object";
146   goto FALLBACK;
147 }
148
149 # The *.so file is under .libs in the source directory.
150 push @DynaLoader::dl_library_path, $libtool_dir;
151 push @DynaLoader::dl_library_path, "$libtool_dir/.libs";
152
153 $dlpath = DynaLoader::dl_findfile($dlname);
154 if (!$dlpath) {
155   _fatal "$module_name: couldn't find $dlname";
156   goto FALLBACK;
157 }
158
159  #my $flags = dl_load_flags $module; # This is 0 in DynaLoader
160  my $flags = 0;
161  my $libref = DynaLoader::dl_load_file($dlpath, $flags);
162  if (!$libref) {
163    _fatal "$module_name: couldn't load file $dlpath";
164    goto FALLBACK;
165  }
166  _debug "$dlpath loaded";
167  my @undefined_symbols = DynaLoader::dl_undef_symbols();
168  if ($#undefined_symbols+1 != 0) {
169    _fatal "$module_name: still have undefined symbols after dl_load_file";
170  }
171  my $bootname = "boot_$module";
172  $bootname =~ s/:/_/g;
173  _debug "looking for $bootname";
174  my $symref = DynaLoader::dl_find_symbol($libref, $bootname);
175  if (!$symref) {
176    _fatal "$module_name: couldn't find $bootname symbol";
177    goto FALLBACK;
178  }
179  _debug "trying to call $bootname...";
180  my $boot_fn = DynaLoader::dl_install_xsub("${module}::bootstrap",
181                                                  $symref, $dlname);
182
183  if (!$boot_fn) {
184    _fatal "$module_name: couldn't bootstrap";
185    goto FALLBACK;
186  }
187  _debug "  ...succeeded";
188
189  push @DynaLoader::dl_shared_objects, $dlpath; # record files loaded
190
191  # This is the module bootstrap function, which causes all the other
192  # functions (XSUB's) provided by the module to become available to
193  # be called from Perl code.
194  &$boot_fn($module, $interface_version);
195
196  # This makes it easier to refer to packages and symbols by name.
197  no strict 'refs';
198
199  if (defined &{"${module}::init"}
200      and !&{"${module}::init"} ($Texinfo::ModulePath::texinfo_uninstalled,
201                                 $Texinfo::ModulePath::builddir)) {
202    _fatal "$module_name: error initializing";
203    goto FALLBACK;
204  }
205
206  if ($perl_extra_file) {
207    eval "require $perl_extra_file";
208  }
209
210  return $module;
211
212FALLBACK:
213  if ($TEXINFO_XS eq 'required') {
214    die "unset the TEXINFO_XS environment variable to use the "
215       ."pure Perl modules\n";
216  } elsif ($TEXINFO_XS eq 'warn' or $TEXINFO_XS eq 'debug') {
217    warn "falling back to pure Perl module $fallback_module\n";
218  }
219  if (!defined $fallback_module) {
220    warn "no fallback module for $module\n";
221    die "unset the TEXINFO_XS and TEXINFO_XS_PARSER environment variables "
222       ."to use the pure Perl modules\n";
223  }
224
225  # Fall back to using the Perl code.
226  # Use eval here to interpret :: properly in module name.
227  eval "require $fallback_module";
228  if ($@) {
229    warn();
230    die "Error loading $fallback_module\n";
231  }
232
233  return  $fallback_module;
234} # end init
235
236# Override subroutine $TARGET with $SOURCE.
237sub override {
238  my ($target, $source) = @_;
239
240  _debug "attempting to override $target with $source...";
241
242  no strict 'refs'; # access modules and symbols by name.
243  no warnings 'redefine'; # do not warn about redefining a function.
244
245  if (defined &{"${source}"}) {
246    *{"${target}"} = \&{"${source}"};
247    _debug "  ...succeeded";
248  } else {
249    _debug "  ...failed";
250  }
251}
252
253
2541;
255__END__
256