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