|
|
What this is
This file is included in the DevDaily.com
"Perl Source Code
Warehouse" project. The intent of this project is to help you "Learn
Perl by Example" TM.
Other links
The source code
#
# Create the export list for perl.
#
# Needed by WIN32 and OS/2 for creating perl.dll,
# and by AIX for creating libperl.a when -Dusershrplib is in effect,
# and by MacOS Classic.
#
# reads global.sym, pp.sym, perlvars.h, intrpvar.h, thrdvar.h, config.h
# On OS/2 reads miniperl.map and the previous version of perl5.def as well
my $PLATFORM;
my $CCTYPE;
while (@ARGV) {
my $flag = shift;
if ($flag =~ s/^CC_FLAGS=/ /) {
for my $fflag ($flag =~ /(?:^|\s)-D(\S+)/g) {
$fflag .= '=1' unless $fflag =~ /^(\w+)=/;
$define{$1} = $2 if $fflag =~ /^(\w+)=(.+)$/;
}
next;
}
$define{$1} = 1 if ($flag =~ /^-D(\w+)$/);
$define{$1} = $2 if ($flag =~ /^-D(\w+)=(.+)$/);
$CCTYPE = $1 if ($flag =~ /^CCTYPE=(\w+)$/);
$PLATFORM = $1 if ($flag =~ /^PLATFORM=(\w+)$/);
if ($PLATFORM eq 'netware') {
$FILETYPE = $1 if ($flag =~ /^FILETYPE=(\w+)$/);
}
}
my @PLATFORM = qw(aix win32 wince os2 MacOS netware);
my %PLATFORM;
@PLATFORM{@PLATFORM} = ();
defined $PLATFORM || die "PLATFORM undefined, must be one of: @PLATFORM\n";
exists $PLATFORM{$PLATFORM} || die "PLATFORM must be one of: @PLATFORM\n";
my %exportperlmalloc =
(
Perl_malloc => "malloc",
Perl_mfree => "free",
Perl_realloc => "realloc",
Perl_calloc => "calloc",
);
my $exportperlmalloc = $PLATFORM eq 'os2';
my $config_sh = "config.sh";
my $config_h = "config.h";
my $thrdvar_h = "thrdvar.h";
my $intrpvar_h = "intrpvar.h";
my $perlvars_h = "perlvars.h";
my $global_sym = "global.sym";
my $pp_sym = "pp.sym";
my $globvar_sym = "globvar.sym";
my $perlio_sym = "perlio.sym";
if ($PLATFORM eq 'aix') {
# Nothing for now.
}
elsif ($PLATFORM =~ /^win(?:32|ce)$/ || $PLATFORM eq 'netware') {
$CCTYPE = "MSVC" unless defined $CCTYPE;
foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym,
$pp_sym, $globvar_sym, $perlio_sym) {
s!^!..\\!;
}
}
elsif ($PLATFORM eq 'MacOS') {
foreach ($thrdvar_h, $intrpvar_h, $perlvars_h, $global_sym,
$pp_sym, $globvar_sym, $perlio_sym) {
s!^!::!;
}
}
unless ($PLATFORM eq 'win32' || $PLATFORM eq 'wince' || $PLATFORM eq 'MacOS' || $PLATFORM eq 'netware') {
open(CFG,$config_sh) || die "Cannot open $config_sh: $!\n";
while () {
if (/^(?:ccflags|optimize)='(.+)'$/) {
$_ = $1;
$define{$1} = 1 while /-D(\w+)/g;
}
if ($PLATFORM eq 'os2') {
$CONFIG_ARGS = $1 if /^config_args='(.+)'$/;
$ARCHNAME = $1 if /^archname='(.+)'$/;
$PATCHLEVEL = $1 if /^perl_patchlevel='(.+)'$/;
}
}
close(CFG);
}
open(CFG,$config_h) || die "Cannot open $config_h: $!\n";
while () {
$define{$1} = 1 if /^\s*#\s*define\s+(MYMALLOC)\b/;
$define{$1} = 1 if /^\s*#\s*define\s+(MULTIPLICITY)\b/;
$define{$1} = 1 if /^\s*#\s*define\s+(PERL_\w+)\b/;
$define{$1} = 1 if /^\s*#\s*define\s+(USE_\w+)\b/;
}
close(CFG);
# perl.h logic duplication begins
if ($define{PERL_IMPLICIT_SYS}) {
$define{PL_OP_SLAB_ALLOC} = 1;
}
if ($define{USE_ITHREADS}) {
if (!$define{MULTIPLICITY}) {
$define{MULTIPLICITY} = 1;
}
}
$define{PERL_IMPLICIT_CONTEXT} ||=
$define{USE_ITHREADS} ||
$define{USE_5005THREADS} ||
$define{MULTIPLICITY} ;
if ($define{USE_ITHREADS} && $PLATFORM ne 'win32' && $^O ne 'darwin') {
$define{USE_REENTRANT_API} = 1;
}
# perl.h logic duplication ends
my $sym_ord = 0;
if ($PLATFORM =~ /^win(?:32|ce)$/) {
warn join(' ',keys %define)."\n";
($dll = ($define{PERL_DLL} || "perl58")) =~ s/\.dll$//i;
print "LIBRARY $dll\n";
print "DESCRIPTION 'Perl interpreter'\n";
print "EXPORTS\n";
if ($define{PERL_IMPLICIT_SYS}) {
output_symbol("perl_get_host_info");
output_symbol("perl_alloc_override");
}
if ($define{USE_ITHREADS} and $define{PERL_IMPLICIT_SYS}) {
output_symbol("perl_clone_host");
}
}
elsif ($PLATFORM eq 'os2') {
if (open my $fh, '<', 'perl5.def') {
while (<$fh>) {
last if /^\s*EXPORTS\b/;
}
while (<$fh>) {
$ordinal{$1} = $2 if /^\s*"(\w+)"\s*(?:=\s*"\w+"\s*)?\@(\d+)\s*$/;
# This allows skipping ordinals which were used in older versions
$sym_ord = $1 if /^\s*;\s*LAST_ORDINAL\s*=\s*(\d+)\s*$/;
}
$sym_ord < $_ and $sym_ord = $_ for values %ordinal; # Take the max
}
($v = $]) =~ s/(\d\.\d\d\d)(\d\d)$/$1_$2/;
$v .= '-thread' if $ARCHNAME =~ /-thread/;
($dll = $define{PERL_DLL}) =~ s/\.dll$//i;
$v .= "\@$PATCHLEVEL" if $PATCHLEVEL;
$d = "DESCRIPTION '\@#perl5-porters\@perl.org:$v#\@ Perl interpreter, configured as $CONFIG_ARGS'";
$d = substr($d, 0, 249) . "...'" if length $d > 253;
print <<"---EOP---";
LIBRARY '$dll' INITINSTANCE TERMINSTANCE
$d
STACKSIZE 32768
CODE LOADONCALL
DATA LOADONCALL NONSHARED MULTIPLE
EXPORTS
---EOP---
}
elsif ($PLATFORM eq 'aix') {
$OSVER = `uname -v`;
chop $OSVER;
$OSREL = `uname -r`;
chop $OSREL;
if ($OSVER > 4 || ($OSVER == 4 && $OSREL >= 3)) {
print "#! ..\n";
} else {
print "#!\n";
}
}
elsif ($PLATFORM eq 'netware') {
if ($FILETYPE eq 'def') {
print "LIBRARY perl58\n";
print "DESCRIPTION 'Perl interpreter for NetWare'\n";
print "EXPORTS\n";
}
if ($define{PERL_IMPLICIT_SYS}) {
output_symbol("perl_get_host_info");
output_symbol("perl_alloc_override");
output_symbol("perl_clone_host");
}
}
my %skip;
my %export;
sub skip_symbols {
my $list = shift;
foreach my $symbol (@$list) {
$skip{$symbol} = 1;
}
}
sub emit_symbols {
my $list = shift;
foreach my $symbol (@$list) {
my $skipsym = $symbol;
# XXX hack
if ($define{MULTIPLICITY}) {
$skipsym =~ s/^Perl_[GIT](\w+)_ptr$/PL_$1/;
}
emit_symbol($symbol) unless exists $skip{$skipsym};
}
}
if ($PLATFORM eq 'win32') {
skip_symbols [qw(
PL_statusvalue_vms
PL_archpat_auto
PL_cryptseen
PL_DBcv
PL_generation
PL_lastgotoprobe
PL_linestart
PL_modcount
PL_pending_ident
PL_sortcxix
PL_sublex_info
PL_timesbuf
main
Perl_ErrorNo
Perl_GetVars
Perl_do_exec3
Perl_do_ipcctl
Perl_do_ipcget
Perl_do_msgrcv
Perl_do_msgsnd
Perl_do_semop
Perl_do_shmio
Perl_dump_fds
Perl_init_thread_intern
Perl_my_bzero
Perl_my_bcopy
Perl_my_htonl
Perl_my_ntohl
Perl_my_swap
Perl_my_chsize
Perl_same_dirent
Perl_setenv_getix
Perl_unlnk
Perl_watch
Perl_safexcalloc
Perl_safexmalloc
Perl_safexfree
Perl_safexrealloc
Perl_my_memcmp
Perl_my_memset
PL_cshlen
PL_cshname
PL_opsave
Perl_do_exec
Perl_getenv_len
Perl_my_pclose
Perl_my_popen
)];
}
else {
skip_symbols [qw(
Perl_do_spawn
Perl_do_spawn_nowait
Perl_do_aspawn
)];
}
if ($PLATFORM eq 'wince') {
skip_symbols [qw(
PL_statusvalue_vms
PL_archpat_auto
PL_cryptseen
PL_DBcv
PL_generation
PL_lastgotoprobe
PL_linestart
PL_modcount
PL_pending_ident
PL_sortcxix
PL_sublex_info
PL_timesbuf
PL_collation_ix
PL_collation_name
PL_collation_standard
PL_collxfrm_base
PL_collxfrm_mult
PL_numeric_compat1
PL_numeric_local
PL_numeric_name
PL_numeric_radix_sv
PL_numeric_standard
PL_vtbl_collxfrm
Perl_sv_collxfrm
setgid
setuid
win32_free_childdir
win32_free_childenv
win32_get_childdir
win32_get_childenv
win32_spawnvp
main
Perl_ErrorNo
Perl_GetVars
Perl_do_exec3
Perl_do_ipcctl
Perl_do_ipcget
Perl_do_msgrcv
Perl_do_msgsnd
Perl_do_semop
Perl_do_shmio
Perl_dump_fds
Perl_init_thread_intern
Perl_my_bzero
Perl_my_bcopy
Perl_my_htonl
Perl_my_ntohl
Perl_my_swap
Perl_my_chsize
Perl_same_dirent
Perl_setenv_getix
Perl_unlnk
Perl_watch
Perl_safexcalloc
Perl_safexmalloc
Perl_safexfree
Perl_safexrealloc
Perl_my_memcmp
Perl_my_memset
PL_cshlen
PL_cshname
PL_opsave
Perl_do_exec
Perl_getenv_len
Perl_my_pclose
Perl_my_popen
)];
}
elsif ($PLATFORM eq 'aix') {
skip_symbols([qw(
Perl_dump_fds
Perl_ErrorNo
Perl_GetVars
Perl_my_bcopy
Perl_my_bzero
Perl_my_chsize
Perl_my_htonl
Perl_my_memcmp
Perl_my_memset
Perl_my_ntohl
Perl_my_swap
Perl_safexcalloc
Perl_safexfree
Perl_safexmalloc
Perl_safexrealloc
Perl_same_dirent
Perl_unlnk
Perl_sys_intern_clear
Perl_sys_intern_dup
Perl_sys_intern_init
PL_cryptseen
PL_opsave
PL_statusvalue_vms
PL_sys_intern
)]);
}
elsif ($PLATFORM eq 'os2') {
emit_symbols([qw(
ctermid
get_sysinfo
Perl_OS2_init
Perl_OS2_init3
Perl_OS2_term
OS2_Perl_data
dlopen
dlsym
dlerror
dlclose
dup2
dup
my_tmpfile
my_tmpnam
my_flock
my_rmdir
my_mkdir
my_getpwuid
my_getpwnam
my_getpwent
my_setpwent
my_endpwent
fork_with_resources
croak_with_os2error
setgrent
endgrent
getgrent
malloc_mutex
threads_mutex
nthreads
nthreads_cond
os2_cond_wait
os2_stat
os2_execname
async_mssleep
msCounter
InfoTable
pthread_join
pthread_create
pthread_detach
XS_Cwd_change_drive
XS_Cwd_current_drive
XS_Cwd_extLibpath
XS_Cwd_extLibpath_set
XS_Cwd_sys_abspath
XS_Cwd_sys_chdir
XS_Cwd_sys_cwd
XS_Cwd_sys_is_absolute
XS_Cwd_sys_is_relative
XS_Cwd_sys_is_rooted
XS_DynaLoader_mod2fname
XS_File__Copy_syscopy
Perl_Register_MQ
Perl_Deregister_MQ
Perl_Serve_Messages
Perl_Process_Messages
init_PMWIN_entries
PMWIN_entries
Perl_hab_GET
loadByOrdinal
pExtFCN
os2error
ResetWinError
CroakWinError
PL_do_undump
)]);
emit_symbols([qw(os2_cond_wait
pthread_join
pthread_create
pthread_detach
)])
if $define{'USE_5005THREADS'} or $define{'USE_ITHREADS'};
}
elsif ($PLATFORM eq 'MacOS') {
skip_symbols [qw(
Perl_GetVars
PL_cryptseen
PL_cshlen
PL_cshname
PL_statusvalue_vms
PL_sys_intern
PL_opsave
PL_timesbuf
Perl_dump_fds
Perl_my_bcopy
Perl_my_bzero
Perl_my_chsize
Perl_my_htonl
Perl_my_memcmp
Perl_my_memset
Perl_my_ntohl
Perl_my_swap
Perl_safexcalloc
Perl_safexfree
Perl_safexmalloc
Perl_safexrealloc
Perl_unlnk
Perl_sys_intern_clear
Perl_sys_intern_init
)];
}
elsif ($PLATFORM eq 'netware') {
skip_symbols [qw(
PL_statusvalue_vms
PL_archpat_auto
PL_cryptseen
PL_DBcv
PL_generation
PL_lastgotoprobe
PL_linestart
PL_modcount
PL_pending_ident
PL_sortcxix
PL_sublex_info
PL_timesbuf
main
Perl_ErrorNo
Perl_GetVars
Perl_do_exec3
Perl_do_ipcctl
Perl_do_ipcget
Perl_do_msgrcv
Perl_do_msgsnd
Perl_do_semop
Perl_do_shmio
Perl_dump_fds
Perl_init_thread_intern
Perl_my_bzero
Perl_my_htonl
Perl_my_ntohl
Perl_my_swap
Perl_my_chsize
Perl_same_dirent
Perl_setenv_getix
Perl_unlnk
Perl_watch
Perl_safexcalloc
Perl_safexmalloc
Perl_safexfree
Perl_safexrealloc
Perl_my_memcmp
Perl_my_memset
PL_cshlen
PL_cshname
PL_opsave
Perl_do_exec
Perl_getenv_len
Perl_my_pclose
Perl_my_popen
Perl_sys_intern_init
Perl_sys_intern_dup
Perl_sys_intern_clear
Perl_my_bcopy
Perl_PerlIO_write
Perl_PerlIO_unread
Perl_PerlIO_tell
Perl_PerlIO_stdout
Perl_PerlIO_stdin
Perl_PerlIO_stderr
Perl_PerlIO_setlinebuf
Perl_PerlIO_set_ptrcnt
Perl_PerlIO_set_cnt
Perl_PerlIO_seek
Perl_PerlIO_read
Perl_PerlIO_get_ptr
Perl_PerlIO_get_cnt
Perl_PerlIO_get_bufsiz
Perl_PerlIO_get_base
Perl_PerlIO_flush
Perl_PerlIO_fill
Perl_PerlIO_fileno
Perl_PerlIO_error
Perl_PerlIO_eof
Perl_PerlIO_close
Perl_PerlIO_clearerr
PerlIO_perlio
)];
}
unless ($define{'DEBUGGING'}) {
skip_symbols [qw(
Perl_deb_growlevel
Perl_debop
Perl_debprofdump
Perl_debstack
Perl_debstackptrs
Perl_sv_peek
PL_block_type
PL_watchaddr
PL_watchok
)];
}
if ($define{'PERL_IMPLICIT_SYS'}) {
skip_symbols [qw(
Perl_getenv_len
Perl_my_popen
Perl_my_pclose
)];
}
else {
skip_symbols [qw(
PL_Mem
PL_MemShared
PL_MemParse
PL_Env
PL_StdIO
PL_LIO
PL_Dir
PL_Sock
PL_Proc
)];
}
unless ($define{'PERL_FLEXIBLE_EXCEPTIONS'}) {
skip_symbols [qw(
PL_protect
Perl_default_protect
Perl_vdefault_protect
)];
}
unless ($define{'USE_REENTRANT_API'}) {
skip_symbols [qw(
PL_reentrant_buffer
)];
}
if ($define{'MYMALLOC'}) {
emit_symbols [qw(
Perl_dump_mstats
Perl_get_mstats
Perl_strdup
Perl_putenv
MallocCfg_ptr
MallocCfgP_ptr
)];
if ($define{'USE_5005THREADS'} || $define{'USE_ITHREADS'}) {
emit_symbols [qw(
PL_malloc_mutex
)];
}
else {
skip_symbols [qw(
PL_malloc_mutex
)];
}
}
else {
skip_symbols [qw(
PL_malloc_mutex
Perl_dump_mstats
Perl_get_mstats
Perl_malloced_size
MallocCfg_ptr
MallocCfgP_ptr
)];
}
if ($define{'PERL_MALLOC_WRAP'}) {
emit_symbols [qw(
PL_memory_wrap
)];
}
unless ($define{'USE_5005THREADS'} || $define{'USE_ITHREADS'}) {
skip_symbols [qw(
PL_thr_key
)];
}
unless ($define{'USE_5005THREADS'}) {
skip_symbols [qw(
PL_sv_mutex
PL_strtab_mutex
PL_svref_mutex
PL_cred_mutex
PL_eval_mutex
PL_fdpid_mutex
PL_sv_lock_mutex
PL_eval_cond
PL_eval_owner
PL_threads_mutex
PL_nthreads
PL_nthreads_cond
PL_threadnum
PL_threadsv_names
PL_thrsv
PL_vtbl_mutex
Perl_condpair_magic
Perl_new_struct_thread
Perl_per_thread_magicals
Perl_thread_create
Perl_find_threadsv
Perl_unlock_condpair
Perl_magic_mutexfree
Perl_sv_lock
)];
}
unless ($define{'USE_ITHREADS'}) {
skip_symbols [qw(
PL_ptr_table
PL_op_mutex
PL_regex_pad
PL_regex_padav
PL_sharedsv_space
PL_sharedsv_space_mutex
PL_dollarzero_mutex
Perl_dirp_dup
Perl_cx_dup
Perl_si_dup
Perl_any_dup
Perl_ss_dup
Perl_fp_dup
Perl_gp_dup
Perl_he_dup
Perl_mg_dup
Perl_re_dup
Perl_sv_dup
Perl_sys_intern_dup
Perl_ptr_table_clear
Perl_ptr_table_fetch
Perl_ptr_table_free
Perl_ptr_table_new
Perl_ptr_table_clear
Perl_ptr_table_free
Perl_ptr_table_split
Perl_ptr_table_store
perl_clone
perl_clone_using
Perl_sharedsv_find
Perl_sharedsv_init
Perl_sharedsv_lock
Perl_sharedsv_new
Perl_sharedsv_thrcnt_dec
Perl_sharedsv_thrcnt_inc
Perl_sharedsv_unlock
)];
}
unless ($define{'PERL_IMPLICIT_CONTEXT'}) {
skip_symbols [qw(
Perl_croak_nocontext
Perl_die_nocontext
Perl_deb_nocontext
Perl_form_nocontext
Perl_load_module_nocontext
Perl_mess_nocontext
Perl_warn_nocontext
Perl_warner_nocontext
Perl_newSVpvf_nocontext
Perl_sv_catpvf_nocontext
Perl_sv_setpvf_nocontext
Perl_sv_catpvf_mg_nocontext
Perl_sv_setpvf_mg_nocontext
)];
}
unless ($define{'PERL_IMPLICIT_SYS'}) {
skip_symbols [qw(
perl_alloc_using
perl_clone_using
)];
}
unless ($define{'FAKE_THREADS'}) {
skip_symbols [qw(PL_curthr)];
}
unless ($define{'PL_OP_SLAB_ALLOC'}) {
skip_symbols [qw(
PL_OpPtr
PL_OpSlab
PL_OpSpace
Perl_Slab_Alloc
Perl_Slab_Free
)];
}
unless ($define{'THREADS_HAVE_PIDS'}) {
skip_symbols [qw(PL_ppid)];
}
sub readvar {
my $file = shift;
my $proc = shift || sub { "PL_$_[2]" };
open(VARS,$file) || die "Cannot open $file: $!\n";
my @syms;
while () {
# All symbols have a Perl_ prefix because that's what embed.h
# sticks in front of them.
push(@syms, &$proc($1,$2,$3)) if (/\bPERLVAR(A?I?C?)\(([IGT])(\w+)/);
}
close(VARS);
return \@syms;
}
if ($define{'USE_5005THREADS'}) {
my $thrd = readvar($thrdvar_h);
skip_symbols $thrd;
}
if ($define{'PERL_GLOBAL_STRUCT'}) {
my $global = readvar($perlvars_h);
skip_symbols $global;
emit_symbol('Perl_GetVars');
emit_symbols [qw(PL_Vars PL_VarsPtr)] unless $CCTYPE eq 'GCC';
}
# functions from *.sym files
my @syms = ($global_sym, $globvar_sym); # $pp_sym is not part of the API
# Symbols that are the public face of the PerlIO layers implementation
# These are in _addition to_ the public face of the abstraction
# and need to be exported to allow XS modules to implement layers
my @layer_syms = qw(
PerlIOBase_binmode
PerlIOBase_clearerr
PerlIOBase_close
PerlIOBase_dup
PerlIOBase_eof
PerlIOBase_error
PerlIOBase_fileno
PerlIOBase_noop_fail
PerlIOBase_noop_ok
PerlIOBase_popped
PerlIOBase_pushed
PerlIOBase_read
PerlIOBase_setlinebuf
PerlIOBase_unread
PerlIOBuf_bufsiz
PerlIOBuf_close
PerlIOBuf_dup
PerlIOBuf_fill
PerlIOBuf_flush
PerlIOBuf_get_base
PerlIOBuf_get_cnt
PerlIOBuf_get_ptr
PerlIOBuf_open
PerlIOBuf_popped
PerlIOBuf_pushed
PerlIOBuf_read
PerlIOBuf_seek
PerlIOBuf_set_ptrcnt
PerlIOBuf_tell
PerlIOBuf_unread
PerlIOBuf_write
PerlIO_allocate
PerlIO_apply_layera
PerlIO_apply_layers
PerlIO_arg_fetch
PerlIO_debug
PerlIO_define_layer
PerlIO_isutf8
PerlIO_layer_fetch
PerlIO_list_free
PerlIO_modestr
PerlIO_parse_layers
PerlIO_pending
PerlIO_perlio
PerlIO_pop
PerlIO_push
PerlIO_sv_dup
Perl_PerlIO_clearerr
Perl_PerlIO_close
Perl_PerlIO_eof
Perl_PerlIO_error
Perl_PerlIO_fileno
Perl_PerlIO_fill
Perl_PerlIO_flush
Perl_PerlIO_get_base
Perl_PerlIO_get_bufsiz
Perl_PerlIO_get_cnt
Perl_PerlIO_get_ptr
Perl_PerlIO_read
Perl_PerlIO_seek
Perl_PerlIO_set_cnt
Perl_PerlIO_set_ptrcnt
Perl_PerlIO_setlinebuf
Perl_PerlIO_stderr
Perl_PerlIO_stdin
Perl_PerlIO_stdout
Perl_PerlIO_tell
Perl_PerlIO_unread
Perl_PerlIO_write
);
if ($PLATFORM eq 'netware') {
push(@layer_syms,'PL_def_layerlist','PL_known_layers','PL_perlio');
}
if ($define{'USE_PERLIO'}) {
# Export the symols that make up the PerlIO abstraction, regardless
# of its implementation - read from a file
push @syms, $perlio_sym;
# This part is then dependent on how the abstraction is implemented
if ($define{'USE_SFIO'}) {
# Old legacy non-stdio "PerlIO"
skip_symbols \@layer_syms;
# SFIO defines most of the PerlIO routines as macros
# So undo most of what $perlio_sym has just done - d'oh !
# Perhaps it would be better to list the ones which do exist
# And emit them
skip_symbols [qw(
PerlIO_canset_cnt
PerlIO_clearerr
PerlIO_close
PerlIO_eof
PerlIO_error
PerlIO_exportFILE
PerlIO_fast_gets
PerlIO_fdopen
PerlIO_fileno
PerlIO_findFILE
PerlIO_flush
PerlIO_get_base
PerlIO_get_bufsiz
PerlIO_get_cnt
PerlIO_get_ptr
PerlIO_getc
PerlIO_getname
PerlIO_has_base
PerlIO_has_cntptr
PerlIO_importFILE
PerlIO_open
PerlIO_printf
PerlIO_putc
PerlIO_puts
PerlIO_read
PerlIO_releaseFILE
PerlIO_reopen
PerlIO_rewind
PerlIO_seek
PerlIO_set_cnt
PerlIO_set_ptrcnt
PerlIO_setlinebuf
PerlIO_sprintf
PerlIO_stderr
PerlIO_stdin
PerlIO_stdout
PerlIO_stdoutf
PerlIO_tell
PerlIO_ungetc
PerlIO_vprintf
PerlIO_write
PerlIO_perlio
Perl_PerlIO_clearerr
Perl_PerlIO_close
Perl_PerlIO_eof
Perl_PerlIO_error
Perl_PerlIO_fileno
Perl_PerlIO_fill
Perl_PerlIO_flush
Perl_PerlIO_get_base
Perl_PerlIO_get_bufsiz
Perl_PerlIO_get_cnt
Perl_PerlIO_get_ptr
Perl_PerlIO_read
Perl_PerlIO_seek
Perl_PerlIO_set_cnt
Perl_PerlIO_set_ptrcnt
Perl_PerlIO_setlinebuf
Perl_PerlIO_stderr
Perl_PerlIO_stdin
Perl_PerlIO_stdout
Perl_PerlIO_tell
Perl_PerlIO_unread
Perl_PerlIO_write
PL_def_layerlist
PL_known_layers
PL_perlio
)];
}
else {
# PerlIO with layers - export implementation
emit_symbols \@layer_syms;
}
} else {
# -Uuseperlio
# Skip the PerlIO layer symbols - although
# nothing should have exported them any way
skip_symbols \@layer_syms;
skip_symbols [qw(PL_def_layerlist PL_known_layers PL_perlio)];
# Also do NOT add abstraction symbols from $perlio_sym
# abstraction is done as #define to stdio
# Remaining remnants that _may_ be functions
# are handled in
}
for my $syms (@syms) {
open (GLOBAL, "<$syms") || die "failed to open $syms: $!\n";
while () {
next if (!/^[A-Za-z]/);
# Functions have a Perl_ prefix
# Variables have a PL_ prefix
chomp($_);
my $symbol = ($syms =~ /var\.sym$/i ? "PL_" : "");
$symbol .= $_;
emit_symbol($symbol) unless exists $skip{$symbol};
}
close(GLOBAL);
}
# variables
if ($define{'MULTIPLICITY'}) {
for my $f ($perlvars_h, $intrpvar_h, $thrdvar_h) {
my $glob = readvar($f, sub { "Perl_" . $_[1] . $_[2] . "_ptr" });
emit_symbols $glob;
}
# XXX AIX seems to want the perlvars.h symbols, for some reason
if ($PLATFORM eq 'aix' or $PLATFORM eq 'os2') { # OS/2 needs PL_thr_key
my $glob = readvar($perlvars_h);
emit_symbols $glob;
}
}
else {
unless ($define{'PERL_GLOBAL_STRUCT'}) {
my $glob = readvar($perlvars_h);
emit_symbols $glob;
}
unless ($define{'MULTIPLICITY'}) {
my $glob = readvar($intrpvar_h);
emit_symbols $glob;
}
unless ($define{'MULTIPLICITY'} || $define{'USE_5005THREADS'}) {
my $glob = readvar($thrdvar_h);
emit_symbols $glob;
}
}
sub try_symbol {
my $symbol = shift;
return if $symbol !~ /^[A-Za-z_]/;
return if $symbol =~ /^\#/;
$symbol =~s/\r//g;
chomp($symbol);
return if exists $skip{$symbol};
emit_symbol($symbol);
}
while () {
try_symbol($_);
}
if ($PLATFORM =~ /^win(?:32|ce)$/) {
foreach my $symbol (qw(
setuid
setgid
boot_DynaLoader
Perl_init_os_extras
Perl_thread_create
Perl_win32_init
Perl_win32_term
RunPerl
win32_async_check
win32_errno
win32_environ
win32_abort
win32_fstat
win32_stat
win32_pipe
win32_popen
win32_pclose
win32_rename
win32_setmode
win32_chsize
win32_lseek
win32_tell
win32_dup
win32_dup2
win32_open
win32_close
win32_eof
win32_read
win32_write
win32_spawnvp
win32_mkdir
win32_rmdir
win32_chdir
win32_flock
win32_execv
win32_execvp
win32_htons
win32_ntohs
win32_htonl
win32_ntohl
win32_inet_addr
win32_inet_ntoa
win32_socket
win32_bind
win32_listen
win32_accept
win32_connect
win32_send
win32_sendto
win32_recv
win32_recvfrom
win32_shutdown
win32_closesocket
win32_ioctlsocket
win32_setsockopt
win32_getsockopt
win32_getpeername
win32_getsockname
win32_gethostname
win32_gethostbyname
win32_gethostbyaddr
win32_getprotobyname
win32_getprotobynumber
win32_getservbyname
win32_getservbyport
win32_select
win32_endhostent
win32_endnetent
win32_endprotoent
win32_endservent
win32_getnetent
win32_getnetbyname
win32_getnetbyaddr
win32_getprotoent
win32_getservent
win32_sethostent
win32_setnetent
win32_setprotoent
win32_setservent
win32_getenv
win32_putenv
win32_perror
win32_malloc
win32_calloc
win32_realloc
win32_free
win32_sleep
win32_times
win32_access
win32_alarm
win32_chmod
win32_open_osfhandle
win32_get_osfhandle
win32_ioctl
win32_link
win32_unlink
win32_utime
win32_gettimeofday
win32_uname
win32_wait
win32_waitpid
win32_kill
win32_str_os_error
win32_opendir
win32_readdir
win32_telldir
win32_seekdir
win32_rewinddir
win32_closedir
win32_longpath
win32_os_id
win32_getpid
win32_crypt
win32_dynaload
win32_get_childenv
win32_free_childenv
win32_clearenv
win32_get_childdir
win32_free_childdir
win32_stdin
win32_stdout
win32_stderr
win32_ferror
win32_feof
win32_strerror
win32_fprintf
win32_printf
win32_vfprintf
win32_vprintf
win32_fread
win32_fwrite
win32_fopen
win32_fdopen
win32_freopen
win32_fclose
win32_fputs
win32_fputc
win32_ungetc
win32_getc
win32_fileno
win32_clearerr
win32_fflush
win32_ftell
win32_fseek
win32_fgetpos
win32_fsetpos
win32_rewind
win32_tmpfile
win32_setbuf
win32_setvbuf
win32_flushall
win32_fcloseall
win32_fgets
win32_gets
win32_fgetc
win32_putc
win32_puts
win32_getchar
win32_putchar
))
{
try_symbol($symbol);
}
}
elsif ($PLATFORM eq 'os2') {
open MAP, 'miniperl.map' or die 'Cannot read miniperl.map';
/^\s*[\da-f:]+\s+(\w+)/i and $mapped{$1}++ foreach |