From: Jarkko Hietaniemi Date: Mon, 18 Apr 2005 13:18:30 +0000 (+0300) Subject: Symbian port of Perl X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=27da23d53ccce622bc51822f59df8def79b4df95;p=p5sagit%2Fp5-mst-13.2.git Symbian port of Perl Message-ID: p4raw-id: //depot/perl@24271 --- diff --git a/EXTERN.h b/EXTERN.h index fe8a0ee..58ca37a 100644 --- a/EXTERN.h +++ b/EXTERN.h @@ -28,8 +28,8 @@ # define EXTCONST globalref # define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly #else -# if defined(WIN32) && !defined(PERL_STATIC_SYMS) -# ifdef PERLDLL +# if (defined(WIN32) || defined(__SYMBIAN32__)) && !defined(PERL_STATIC_SYMS) +# if defined(PERLDLL) || defined(__SYMBIAN32__) # define EXT extern __declspec(dllexport) # define dEXT # define EXTCONST extern __declspec(dllexport) const diff --git a/INTERN.h b/INTERN.h index d2fb950..da3057a 100644 --- a/INTERN.h +++ b/INTERN.h @@ -28,24 +28,24 @@ # define EXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly # define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly #else -#if defined(WIN32) && defined(__MINGW32__) -# define EXT __declspec(dllexport) -# define dEXT -# define EXTCONST __declspec(dllexport) const -# define dEXTCONST const -#else -#ifdef __cplusplus -# define EXT -# define dEXT -# define EXTCONST extern const -# define dEXTCONST const -#else -# define EXT -# define dEXT -# define EXTCONST const -# define dEXTCONST const -#endif -#endif +# if (defined(WIN32) && defined(__MINGW32__)) || defined(__SYMBIAN32__) +# define EXT __declspec(dllexport) +# define dEXT +# define EXTCONST __declspec(dllexport) const +# define dEXTCONST const +# else +# ifdef __cplusplus +# define EXT +# define dEXT +# define EXTCONST extern const +# define dEXTCONST const +# else +# define EXT +# define dEXT +# define EXTCONST const +# define dEXTCONST const +# endif +# endif #endif #undef INIT diff --git a/MANIFEST b/MANIFEST index c791a84..b0361c8 100644 --- a/MANIFEST +++ b/MANIFEST @@ -329,6 +329,7 @@ ext/DynaLoader/dl_mac.xs MacOS implementation ext/DynaLoader/dl_mpeix.xs MPE/iX implementation ext/DynaLoader/dl_next.xs NeXT implementation ext/DynaLoader/dl_none.xs Stub implementation +ext/DynaLoader/dl_symbian.xs Symbian implementation ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files ext/DynaLoader/dl_vmesa.xs VM/ESA implementation ext/DynaLoader/dl_vms.xs VMS implementation @@ -2445,6 +2446,7 @@ README.os400 Perl notes for OS/400 README.plan9 Perl notes for Plan 9 README.qnx Perl notes for QNX README.solaris Perl notes for Solaris +README.symbian Perl notes for Symbian README.tru64 Perl notes for Tru64 README.tw Perl for Traditional Chinese (in Big5) README.uts Perl notes for UTS @@ -2470,6 +2472,37 @@ scope.c Scope entry and exit code scope.h Scope entry and exit header sv.c Scalar value code sv.h Scalar value header +symbian/bld.inf Symbian sample app build config +symbian/config.pl Configuration script for Symbian +symbian/config.sh Configuration data for Symbian +symbian/cwd.pl Helper code for config.pl +symbian/demo_pl "Archive" of demo code +symbian/install.cfg Installation instructions +symbian/makesis.pl Installation file creator +symbian/PerlApp.cpp Symbian sample app code +symbian/PerlApp.h Symbian sample app header +symbian/PerlApp.hrh Symbian sample app resource header +symbian/PerlApp.rss Symbian sample app resource definition +symbian/PerlAppAif.rss Symbian sample app code +symbian/PerlBase.cpp Symbian Perl base class +symbian/PerlBase.h Symbian Perl base class header +symbian/PerlBase.pod Symbian Perl base class documentation +symbian/PerlRecog.cpp Symbian recognizer code +symbian/PerlRecog.mmp Symbian recognizer build +symbian/port.pl Helper code for config.pl +symbian/README ReadMe for the Symbian files +symbian/sanity.pl Helper code for config.pl +symbian/sdk.pl Helper code for config.pl +symbian/symbian_dll.cpp The DLL stub for Symbian +symbian/symbianish.h Header for Symbian +symbian/symbian_proto.h Prototypes for Symbian +symbian/symbian_stubs.c Stub routines for Symbian +symbian/symbian_stubs.h Stub headers for Symbian +symbian/symbian_utils.cpp Helper routines for Symbian +symbian/TODO Symbian things to do +symbian/uid.pl Helper code for config.pl +symbian/version.pl Helper code for config.pl +symbian/xsbuild.pl Building extensions taint.c Tainting code t/base/cond.t See if conditionals work t/base/if.t See if if works diff --git a/Porting/curliff.pl b/Porting/curliff.pl index 636dccd..f3937b9 100644 --- a/Porting/curliff.pl +++ b/Porting/curliff.pl @@ -10,13 +10,20 @@ use strict; use vars qw($r); +# This list is also in makerel. my @FILES = qw( djgpp/configure.bat README.ce README.dos + README.symbian README.win32 + symbian/config.pl + symbian/makesis.pl + symbian/README + symbian/xsbuild.pl win32/Makefile win32/makefile.mk + wince/Makefile.ce wince/compile-all.bat wince/README.perlce wince/registry.bat diff --git a/Porting/makerel b/Porting/makerel index 42b24d6..d4022bb 100644 --- a/Porting/makerel +++ b/Porting/makerel @@ -151,11 +151,17 @@ system("chmod +w @writables") == 0 or die "system: $!"; print "Adding CRs to DOSish files...\n"; +# This list is also in curliff.pl. my @crlf = qw( djgpp/configure.bat README.ce README.dos + README.symbian README.win32 + symbian/config.pl + symbian/makesis.pl + symbian/README + symbian/xsbuild.pl win32/Makefile win32/makefile.mk wince/Makefile.ce diff --git a/README.symbian b/README.symbian new file mode 100644 index 0000000..e6cb4dc --- /dev/null +++ b/README.symbian @@ -0,0 +1,352 @@ +If you read this file _as_is_, just ignore the funny characters you see. +It is written in the POD format (see pod/perlpod.pod) which is specially +designed to be readable as is. + +=head1 NAME + +README.symbian - Perl version 5 on Symbian OS + +=head1 DESCRIPTION + +This document describes various features of the Symbian operating +system that will affect how Perl version 5 (hereafter just Perl) +is compiled and/or runs. + +B +The DLL includes a C++ class called CPerlBase, which one can then +(derive from and) use to embed Perl into applications, see F. + +The base port of Perl to Symbian only implements the basic POSIX-like +functionality; it does not implement any further Symbian or Series 60 +bindings for Perl. + +It is also possible to generate Symbian executables for "miniperl" +and "perl", but since there is no standard command line interface +for Symbian (nor full keyboards in the devices), these are useful +mainly as demonstrations. + +=head2 Compiling Perl on Symbian + +(0) You need to have the Symbian SDK installed. + + These instructions have been tested under various Nokia Series 60 + Symbian SDKs (1.2 to 2.6). You can get the SDKs from + Forum Nokia (http://www.forum.nokia.com/). + + A prerequisite for any of the SDKs is to install ActivePerl + from ActiveState, http://www.activestate.com/Products/ActivePerl/ + + Having the SDK installed also means that you need to have either + the Metrowerks CodeWarrior installed (2.8 and 3.0 were used in testing) + or the Microsoft Visual C++ 6.0 installed (SP3 minimum, SP5 recommended). + + Note that for example the Serie s60 2.0 VC SDK installation talks + about ActivePerl build 518, which does no more (as of mid-2004) exist + at the ActiveState website. The ActivePerl 5.8.4 build 810 was + used successfully for compiling Perl on Symbian. The 5.6.x ActivePerls + do not work. + + Other SDKs or compilers like Visual.NET, command-line-only + Visual.NET, Borland, GnuPoc, or sdk2unix have not been tried. + + These instructions almost certainly won't work with older Symbian + releases or other SDKs. Patches to get this port running in other + releases, SDKs, compilers, platforms, or devices are naturally welcome. + +(1) Get a Perl source code distribution (for example the file + perl-5.9.2.tar.gz is fine) from http://www.cpan.org/src/ + and unpack it in your the C:/Symbian directory of your Windows + system. + +(2) Change to the perl source directory. + + cd c:\Symbian\perl-5.x.x + +(3) Run the following script using the perl coming with the SDK + + perl symbian\config.pl + + You must use the cmd.exe, the Cygwin shell will not work + (the PATH must include the SDK tools, including a Perl, + which should be the case under cmd.exe) + +(4) Build the project, either by + + make all + + in cmd.exe or by using either the Metrowerks CodeWarrior + or the Visual C++ 6.0. + + If you use the VC IDE, you will have to run F + first using the cmd.exe, and then run 'make win.mf vc6.mf' to generate + the VC6 makefiles and workspaces. + + The following Series 60 SDK and compiler configurations and Nokia + phones that were tested (+ = compiled and PerlApp run, - = not), + both for Perl 5.8.x and 5.9.x: + + SDK | VC | CW | + ----+----+----+--- + 1.2 | + | + | 3650 (*) + 2.0 | + | + | 6600 + 2.1 | - | + | 6670 + 2.6 | + | + | 6630 + + If you are using the 'make' directly, it is the GNU make from the SDKs, + and it will invoke the right make commands for the Windows emulator + build and the Arm target builds ('thumb' by default) as necessary. + (*) Compiles but does not work, unfortunately. + + The build scripts assume the 'absolute style' SDK installs under C:, + the 'subst style' will not work. + + If using the VC IDE, to build use for example the File->Open Workspace-> + C:\Symbian\8.as\S60_2nd_FP2\epoc32\build\symbian\perl\perl\wins\perl.dsw + The emulator binaries will appear in the same directory. + + If using the VC IDE, you will a lot of warnings in the beginning of + the build because a lot of headers mentioned by the source cannot + be found, but this is not serious since those headers are not used. + + The Metrowerks will give a lot of warnings about unused variables and + empty declarations, you can ignore those. + + When the Windows and Arm DLLs are built do not be scared by a very long + messages whizzing by: it is the "export freeze" phase where the whole + (rather large) API of Perl is listed. + + Once the build is completed you need to create the DLL SIS file by + + make perldll.sis + + which will create the file perlXYZ.sis (the XYZ being the Perl version) + which you can then install into your Symbian device: an easy way + to do this is to send them via Bluetooth or infrared and just open + the messages. + + Since the total size of all Perl SIS files once installed is + over 1.9 MB, it is recommended to do the installation into a + memory card (drive E:) instead of the C: drive. + + The size of the perlXYZ.SIS is about 370 kB but once it is in the + device it is about one 750 kB (according to the application manager). + + The perlXYZ.sis includes only the Perl DLL: to create an additional + SIS file which includes some of the standard (pure) Perl libraries, + issue the command + + make perllib.sis + + Some of the standard Perl libraries are included, but not all: + see L or F for more details + (250 kB -> 700 kB). + + Some of the standard Perl XS extensions (see L are + also available: + + make perlext.sis + + which will create perlXYZext.sis (210 kB -> 470 kB). + + To compile the demonstration application PerlApp you need first to + install the Perl headers under the SDK. + + To install the Perl headers and the class CPerlBase documentation + so that you no more need the Perl sources around to compile Perl + applications using the SDK: + + make sdkinstall + + The destination directory is C:\Symbian\perl\X.Y.Z. For more + details, see F. + + Once the headers have been installed, you can create a SIS for + the PerlApp: + + make perlapp.sis + + The perlapp.sis (11 kB -> 16 kB) will be built in the symbian + subdirectory, but a copy will also be made to the main directory. + + If you want to package the Perl DLLs (one for WINS, one for ARMI), + the headers, and the documentation: + + make perlsdk.zip + + which will create perlXYZsdk.zip that can be used in another + Windows system with the SDK, without having to compile Perl in + that system. + + If you want to package the PerlApp sources: + + make perlapp.zip + + If you want to package the perl.exe and miniperl.exe, you + can use the perlexe.sis and miniperlexe.sis make targets. + You also probably want the perllib.sis for the libraries + and maybe even the perlapp.sis for the recognizer. + + The make target 'allsis' combines all the above SIS targets. + + To clean up after compilation you can use either of + + make clean + make distclean + + depending on how clean you want to be. + +=head2 Compilation problems + +If you see right after "make" this + + cat makefile.sh >makefile + 'cat' is not recognized as an internal or external command, + operable program or batch file. + +it means you need to (re)run the symbian\config.pl. + +If you get the error + + 'perl' is not recognized as an internal or external command, + operable program or batch file. + +you may need to reinstall the ActivePerl. + +If you see this + + ren makedef.pl nomakedef.pl + The system cannot find the file specified. + C:\Symbian\...\make.exe: [rename_makedef] Error 1 (ignored) + +please ignore it since it is nothing serious (the build process of +renames the Perl makedef.pl as nomakedef.pl to avoid confusing it +with a makedef.pl of the SDK). + +=head2 PerlApp + +The PerlApp application demonstrates how to embed Perl interpreters +to a Symbian application. The "Time" menu item runs the following +Perl code: C, +the "Oneliner" allows one to type in Perl code, and the "Run" +opens a file chooser for selecting a Perl file to run. + +The PerlApp also is started when the "Perl recognizer" (also included +and installed) detects a Perl file being activated througg the GUI, +and offers either to install it under \Perl (if the Perl file is in +the inbox of the messaging application) or to run it (if the Perl file +is under \Perl). + +=head2 Using Perl in Symbian + +First of all note that you have full access to the Symbian device +when using Perl: you can do a lot of damage to your device (like +removing system files) unless you are careful. Please do take +backups before doing anything. + +The Perl port has been done for the most part using the Symbian +standard POSIX-ish STDLIB library. It is a reasonably complete +library, but certain corners of such emulation libraries that tend +to be left unimplemented on non-UNIX platforms have been left +unimplemented also this time: fork(), signals(), user/group ids, +select() working for sockets, non-blocking sockets, and so forth. +See the file symbian/config.sh and look for 'undef' to find the +unsupported APIs (or from Perl use Config). + +The filesystem of Symbian devices uses DOSish syntax, "drives" +separated from paths by a colon, and backslashes for the path. +The exact assignment of the drives probably varies between platforms, +but you might for example see C: as the flash main memory, D: as the +RAM drive, E: as the memory card (MMC), Z: as the ROM. As far the +devices go the NUL: is the bit bucket, the COMx: are the serial lines, +IRCOMx: are the IR ports, TMP: might be C:\System\Temp. Remember to +double those backslashes in doublequoted strings. + +The Perl DLL is installed in \System\Libs\. The Perl libraries and +extension DLLs are installed in \System\Libs\Perl\X.Y.Z\. The PerlApp +is installed in \System\Apps\, and the SIS also installs a couple of +demo scripts in \Perl\. + +Note that the Symbian filesystem is very picky: it strongly prefers +the \ instead of the /. + +When doing XS / Symbian C++ programming include first the Symbian +headers, then any standard C/POSIX headers, then Perl headers, and finally +any application headers. + +New() and Copy() are unfortunately used by both Symbian and Perl code +so you'll have to play cpp games if you need them. PerlBase.h undefines +the Perl definitions and redefines them as PerlNew() and PerlCopy(). + +=head1 TO DO + +Lots. See F. + +=head1 WARNING + +As of Perl Symbian port version 0.1.0 any part of Perl's standard +regression test suite has not been run on a real Symbian device using +the ported Perl, so innumerable bugs may lie in wait. Therefore there +is absolutely no warranty. + +=head1 NOTE + +When creating and extending application programming interfaces (APIs) +for Symbian or Series 60 it is suggested that trademarks, registered +trademarks, or trade names are not used in the API names. Instead, +developers should consider basing the API naming in the existing (C++) +public component and API naming, modified as appropriate by the rules +of the programming language the new APIs are for. + +Nokia is a registered trademark of Nokia Corporation. Nokia's product +names are trademarks or registered trademarks of Nokia. Other product +and company names mentioned herein may be trademarks or trade names of +their respective owners. + +=head1 AUTHOR + +Jarkko Hietaniemi + +=head1 COPYRIGHT + +Copyright (c) 2004-2005 Nokia. All rights reserved. + +=head1 LICENSE + +The Symbian port is licensed under the same terms as Perl itself. + +=head1 HISTORY + +Perl Symbian Port version 0.1.0: April 2005 +(This will show as "0.01" in the Symbian Installer.) + + - The console window is a very simple console indeed: one can + get the newline with "000" and the "C" button is a backspace. + Do not expect a terminal capable of vt100 or ANSI sequences. + The console is also "ASCII", you cannot input e.g. any accented + letters. Because of obvious physical constraints the console is + also very small: (in Nokia 6600) 22 columns, 17 rows. + - The following libraries are available: + AnyDBM_File AutoLoader base Carp Config Cwd constant + DynaLoader Exporter File::Spec integer lib strict Symbol + vars warnings XSLoader + - The following extensions are available: + attrs Cwd Data::Dumper Devel::Peek Digest::MD5 DynaLoader + Fcntl File::Glob Filter::Util::Call IO List::Util MIME::Base64 + PerlIO::scalar PerlIO::via SDBM_File Socket Storable Time::HiRes + - The following extensions are missing for various technical reasons: + B ByteLoader Devel::DProf Devel::PPPort Encode GDBM_File + I18N::Langinfo IPC::SysV NDBM_File Opcode PerlIO::encoding POSIX + re Safe Sys::Hostname Sys::Syslog + threads threads::shared Unicode::Normalize + - Using MakeMaker or the Module::* to build and install modules + is not supported. A future solution might use the native + SIS packaging format (see symbian\TODO). + - Building XS other than the ones in the core is not supported. + +Since this is 0.1.0, any future releases are almost guaranteed to be +binary incompatible. As a sign of this the Symbian symbol exports are +kept unfrozen and the .def files rebuilt every time. + +=cut + diff --git a/XSUB.h b/XSUB.h index 7c059c1..b611581 100644 --- a/XSUB.h +++ b/XSUB.h @@ -80,9 +80,14 @@ is a lexical $_ in scope. #define ST(off) PL_stack_base[ax + (off)] +#undef XS #if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) # define XS(name) __declspec(dllexport) void name(pTHX_ CV* cv) -#else +#endif +#if defined(SYMBIAN) +# define XS(name) EXPORT_C void name(pTHX_ CV* cv) +#endif +#ifndef XS # define XS(name) void name(pTHX_ CV* cv) #endif diff --git a/av.c b/av.c index 549f2df..bc35333 100644 --- a/av.c +++ b/av.c @@ -525,6 +525,7 @@ to accommodate the addition. void Perl_av_push(pTHX_ register AV *av, SV *val) { + dVAR; MAGIC *mg; if (!av) return; @@ -560,6 +561,7 @@ is empty. SV * Perl_av_pop(pTHX_ register AV *av) { + dVAR; SV *retval; MAGIC* mg; @@ -605,6 +607,7 @@ must then use C to assign values to these new elements. void Perl_av_unshift(pTHX_ register AV *av, register I32 num) { + dVAR; register I32 i; register SV **ary; MAGIC* mg; @@ -676,6 +679,7 @@ Shifts an SV off the beginning of the array. SV * Perl_av_shift(pTHX_ register AV *av) { + dVAR; SV *retval; MAGIC* mg; @@ -738,6 +742,7 @@ Perl's C<$#array = $fill;>. void Perl_av_fill(pTHX_ register AV *av, I32 fill) { + dVAR; MAGIC *mg; if (!av) Perl_croak(aTHX_ "panic: null array"); diff --git a/bytecode.pl b/bytecode.pl index adf1d1f..59069b3 100644 --- a/bytecode.pl +++ b/bytecode.pl @@ -105,6 +105,7 @@ bset_obj_store(pTHX_ struct byteloader_state *bstate, void *obj, I32 ix) int byterun(pTHX_ register struct byteloader_state *bstate) { + dVAR; register int insn; U32 ix; SV *specialsv_list[6]; diff --git a/configpm b/configpm index c9f5e34..e986664 100755 --- a/configpm +++ b/configpm @@ -424,12 +424,16 @@ EOT foreach my $prefix (qw(ccflags ldflags)) { my $value = fetch_string ({}, $prefix); my $withlargefiles = fetch_string ({}, $prefix . "_uselargefiles"); - $value =~ s/\Q$withlargefiles\E\b//; - print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n"; + if (defined $withlargefiles) { + $value =~ s/\Q$withlargefiles\E\b//; + print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n"; + } } foreach my $prefix (qw(libs libswanted)) { my $value = fetch_string ({}, $prefix); + my $withlf = fetch_string ({}, 'libswanted_uselargefiles'); + next unless defined $withlf; my @lflibswanted = split(' ', fetch_string ({}, 'libswanted_uselargefiles')); if (@lflibswanted) { @@ -861,6 +865,7 @@ EOS # Now do some simple tests on the Config.pm file we have created unshift(@INC,'lib'); +unshift(@INC,'xlib/symbian') if $Opts{cross}; require $Config_PM; import Config; diff --git a/doio.c b/doio.c index 3847da6..1d7e56f 100644 --- a/doio.c +++ b/doio.c @@ -81,6 +81,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, I32 num_svs) { + dVAR; register IO *io = GvIOn(gv); PerlIO *saveifp = Nullfp; PerlIO *saveofp = Nullfp; @@ -1241,9 +1242,8 @@ Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) } #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) -I32 my_chsize(fd, length) -I32 fd; /* file descriptor */ -Off_t length; /* length to set file to */ +I32 +my_chsize(int fd, Off_t length) { #ifdef F_FREESP /* code courtesy of William Kucharski */ @@ -1287,12 +1287,11 @@ Off_t length; /* length to set file to */ return -1; } - return 0; #else - dTHX; - DIE(aTHX_ "truncate not implemented"); + Perl_croak_nocontext("truncate not implemented"); #endif /* F_FREESP */ + return -1; } #endif /* !HAS_TRUNCATE && !HAS_CHSIZE */ @@ -1418,7 +1417,7 @@ Perl_my_stat(pTHX) } } -static char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat"; +static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat"; I32 Perl_my_lstat(pTHX) @@ -1471,7 +1470,8 @@ bool Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, int fd, int do_report) { -#ifdef MACOS_TRADITIONAL + dVAR; +#if defined(MACOS_TRADITIONAL) || defined(SYMBIAN) Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); #else register char **a; @@ -1527,7 +1527,7 @@ Perl_do_execfree(pTHX) } } -#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) +#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(SYMBIAN) && !defined(MACOS_TRADITIONAL) bool Perl_do_exec(pTHX_ char *cmd) @@ -1538,6 +1538,7 @@ Perl_do_exec(pTHX_ char *cmd) bool Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) { + dVAR; register char **a; register char *s; @@ -2306,6 +2307,7 @@ Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. PerlIO * Perl_start_glob (pTHX_ SV *tmpglob, IO *io) { + dVAR; SV *tmpcmd = NEWSV(55, 0); PerlIO *fp; ENTER; diff --git a/dump.c b/dump.c index cc500e0..2ee5483 100644 --- a/dump.c +++ b/dump.c @@ -25,7 +25,7 @@ #include "perl.h" #include "regcomp.h" -static HV *Sequence; +#define Sequence PL_op_sequence void Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) @@ -153,6 +153,7 @@ Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pv char * Perl_sv_peek(pTHX_ SV *sv) { + dVAR; SV *t = sv_newmortal(); STRLEN n_a; int unref = 0; @@ -404,16 +405,13 @@ Perl_pmop_dump(pTHX_ PMOP *pm) STATIC void sequence(pTHX_ register const OP *o) { + dVAR; SV *op; char *key; STRLEN len; - static UV seq; const OP *oldop = 0; OP *l; - if (!Sequence) - Sequence = newHV(); - if (!o) return; @@ -431,7 +429,7 @@ sequence(pTHX_ register const OP *o) switch (o->op_type) { case OP_STUB: if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; } goto nothin; @@ -445,7 +443,7 @@ sequence(pTHX_ register const OP *o) nothin: if (oldop && o->op_next) continue; - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; case OP_MAPWHILE: @@ -458,7 +456,7 @@ sequence(pTHX_ register const OP *o) case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); for (l = cLOGOPo->op_other; l && l->op_type == OP_NULL; l = l->op_next) ; sequence(aTHX_ l); @@ -466,7 +464,7 @@ sequence(pTHX_ register const OP *o) case OP_ENTERLOOP: case OP_ENTERITER: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); for (l = cLOOPo->op_redoop; l && l->op_type == OP_NULL; l = l->op_next) ; sequence(aTHX_ l); @@ -481,7 +479,7 @@ sequence(pTHX_ register const OP *o) case OP_QR: case OP_MATCH: case OP_SUBST: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); for (l = cPMOPo->op_pmreplstart; l && l->op_type == OP_NULL; l = l->op_next) ; sequence(aTHX_ l); @@ -491,7 +489,7 @@ sequence(pTHX_ register const OP *o) break; default: - hv_store(Sequence, key, len, newSVuv(++seq), 0); + hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); break; } oldop = o; @@ -501,6 +499,7 @@ sequence(pTHX_ register const OP *o) STATIC UV sequence_num(pTHX_ const OP *o) { + dVAR; SV *op, **seq; char *key; @@ -515,6 +514,7 @@ sequence_num(pTHX_ const OP *o) void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) { + dVAR; UV seq; sequence(aTHX_ o); Perl_dump_indent(aTHX_ level, file, "{\n"); @@ -887,7 +887,7 @@ Perl_gv_dump(pTHX_ GV *gv) * (with the PERL_MAGIC_ prefixed stripped) */ -static struct { const char type; const char *name; } magic_names[] = { +static const struct { const char type; const char *name; } magic_names[] = { { PERL_MAGIC_sv, "sv(\\0)" }, { PERL_MAGIC_arylen, "arylen(#)" }, { PERL_MAGIC_glob, "glob(*)" }, @@ -982,7 +982,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 { int n; const char *name = 0; - for (n=0; magic_names[n].name; n++) { + for (n = 0; magic_names[n].name; n++) { if (mg->mg_type == magic_names[n].type) { name = magic_names[n].name; break; diff --git a/embed.fnc b/embed.fnc index 66fb8bf..7373929 100644 --- a/embed.fnc +++ b/embed.fnc @@ -170,7 +170,7 @@ p |void |do_chop |SV* asv|SV* sv Ap |bool |do_close |GV* gv|bool not_implicit p |bool |do_eof |GV* gv p |bool |do_exec |char* cmd -#if defined(WIN32) +#if defined(WIN32) || defined(SYMBIAN) Ap |int |do_aspawn |SV* really|SV** mark|SV** sp Ap |int |do_spawn |char* cmd Ap |int |do_spawn_nowait|char* cmd @@ -245,7 +245,7 @@ Ap |GV* |gv_autoload4 |HV* stash|const char* name|STRLEN len \ |I32 method Ap |void |gv_check |HV* stash Ap |void |gv_efullname |SV* sv|const GV* gv -Amb |void |gv_efullname3 |SV* sv|const GV* gv|const char* prefix +Apmb |void |gv_efullname3 |SV* sv|const GV* gv|const char* prefix Ap |void |gv_efullname4 |SV* sv|const GV* gv|const char* prefix|bool keepmain Ap |GV* |gv_fetchfile |const char* name Apd |GV* |gv_fetchmeth |HV* stash|const char* name|STRLEN len \ @@ -257,7 +257,7 @@ Apd |GV* |gv_fetchmethod_autoload|HV* stash|const char* name \ |I32 autoload Ap |GV* |gv_fetchpv |const char* name|I32 add|I32 sv_type Ap |void |gv_fullname |SV* sv|const GV* gv -Amb |void |gv_fullname3 |SV* sv|const GV* gv|const char* prefix +Apmb |void |gv_fullname3 |SV* sv|const GV* gv|const char* prefix Ap |void |gv_fullname4 |SV* sv|const GV* gv|const char* prefix|bool keepmain Ap |void |gv_init |GV* gv|HV* stash|const char* name \ |STRLEN len|int multi @@ -1290,8 +1290,10 @@ s |SV*|isa_lookup |HV *stash|const char *name|HV *name_stash|int len|int level #endif #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) +#if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE) s |char* |stdize_locale |char* locs #endif +#endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) s |COP* |closest_cop |COP *cop|OP *o @@ -1480,4 +1482,7 @@ dp |bool |is_gv_magical_sv|SV *name|U32 flags Apd |char* |savesvpv |SV* sv +Ap |struct perl_vars*|init_global_struct +Ap |void |free_global_struct|struct perl_vars* + END_EXTERN_C diff --git a/embed.h b/embed.h index 3072781..54c887f 100644 --- a/embed.h +++ b/embed.h @@ -188,7 +188,7 @@ #ifdef PERL_CORE #define do_exec Perl_do_exec #endif -#if defined(WIN32) +#if defined(WIN32) || defined(SYMBIAN) #define do_aspawn Perl_do_aspawn #define do_spawn Perl_do_spawn #define do_spawn_nowait Perl_do_spawn_nowait @@ -1995,10 +1995,12 @@ #endif #endif #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) +#if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE) #ifdef PERL_CORE #define stdize_locale S_stdize_locale #endif #endif +#endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define closest_cop S_closest_cop @@ -2265,6 +2267,8 @@ #define is_gv_magical_sv Perl_is_gv_magical_sv #endif #define savesvpv Perl_savesvpv +#define init_global_struct Perl_init_global_struct +#define free_global_struct Perl_free_global_struct #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_concat Perl_ck_concat @@ -2800,7 +2804,7 @@ #ifdef PERL_CORE #define do_exec(a) Perl_do_exec(aTHX_ a) #endif -#if defined(WIN32) +#if defined(WIN32) || defined(SYMBIAN) #define do_aspawn(a,b,c) Perl_do_aspawn(aTHX_ a,b,c) #define do_spawn(a) Perl_do_spawn(aTHX_ a) #define do_spawn_nowait(a) Perl_do_spawn_nowait(aTHX_ a) @@ -4598,10 +4602,12 @@ #endif #endif #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) +#if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE) #ifdef PERL_CORE #define stdize_locale(a) S_stdize_locale(aTHX_ a) #endif #endif +#endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define closest_cop(a,b) S_closest_cop(aTHX_ a,b) @@ -4868,6 +4874,8 @@ #define is_gv_magical_sv(a,b) Perl_is_gv_magical_sv(aTHX_ a,b) #endif #define savesvpv(a) Perl_savesvpv(aTHX_ a) +#define init_global_struct() Perl_init_global_struct(aTHX) +#define free_global_struct(a) Perl_free_global_struct(aTHX_ a) #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) diff --git a/embed.pl b/embed.pl index ac0822f..1d816b1 100755 --- a/embed.pl +++ b/embed.pl @@ -274,7 +274,7 @@ sub readvars(\%$$@) { or die "embed.pl: Can't open $file: $!\n"; while () { s/[ \t]*#.*//; # Delete comments. - if (/PERLVARA?I?C?\($pre(\w+)/) { + if (/PERLVARA?I?S?C?\($pre(\w+)/) { my $sym = $1; $sym = $pre . $sym if $keep_pre; warn "duplicate symbol $sym while processing $file\n" @@ -609,7 +609,8 @@ print EM <<'END'; END for $sym (sort keys %globvar) { - print EM multon($sym,'G','PL_Vars.'); + print EM multon($sym, 'G','my_vars->'); + print EM multon("G$sym",'', 'my_vars->'); } print EM <<'END'; @@ -662,11 +663,14 @@ START_EXTERN_C #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX); #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \ EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) +#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \ + EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); #include "thrdvar.h" #include "intrpvar.h" @@ -676,6 +680,16 @@ START_EXTERN_C #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC + +#ifndef PERL_GLOBAL_STRUCT +EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX); +EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX); +EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX); +#define Perl_ppaddr_ptr Perl_Gppaddr_ptr +#define Perl_check_ptr Perl_Gcheck_ptr +#define Perl_fold_locale_ptr Perl_Gfold_locale_ptr +#endif END_EXTERN_C @@ -691,9 +705,9 @@ END_EXTERN_C START_EXTERN_C #ifndef DOINIT -EXT void *PL_force_link_funcs[]; +EXTCONST void * const PL_force_link_funcs[]; #else -EXT void *PL_force_link_funcs[] = { +EXTCONST void * const PL_force_link_funcs[] = { #undef PERLVAR #undef PERLVARA #undef PERLVARI @@ -702,6 +716,7 @@ EXT void *PL_force_link_funcs[] = { #define PERLVARA(v,n,t) PERLVAR(v,t) #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v,t) +#define PERLVARISC(v,i) PERLVAR(v,char) #include "thrdvar.h" #include "intrpvar.h" @@ -711,6 +726,7 @@ EXT void *PL_force_link_funcs[] = { #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC }; #endif /* DOINIT */ @@ -759,14 +775,17 @@ START_EXTERN_C #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ - { return &(aTHX->v); } + { dVAR; return &(aTHX->v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ - { return &(aTHX->v); } + { dVAR; return &(aTHX->v); } #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) +#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ + { dVAR; return &(aTHX->v); } #include "thrdvar.h" #include "intrpvar.h" @@ -774,18 +793,42 @@ START_EXTERN_C #undef PERLVAR #undef PERLVARA #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ - { return &(PL_##v); } + { dVAR; return &(PL_##v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ - { return &(PL_##v); } + { dVAR; return &(PL_##v); } #undef PERLVARIC -#define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \ +#undef PERLVARISC +#define PERLVARIC(v,t,i) \ + const t* Perl_##v##_ptr(pTHX) \ { return (const t *)&(PL_##v); } +#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ + { dVAR; return &(PL_##v); } #include "perlvars.h" #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC + +#ifndef PERL_GLOBAL_STRUCT +/* A few evil special cases. Could probably macrofy this. */ +#undef PL_ppaddr +#undef PL_check +#undef PL_fold_locale +Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) { + static const Perl_ppaddr_t* ppaddr_ptr = PL_ppaddr; + return (Perl_ppaddr_t**)&ppaddr_ptr; +} +Perl_check_t** Perl_Gcheck_ptr(pTHX) { + static const Perl_check_t* check_ptr = PL_check; + return (Perl_check_t**)&check_ptr; +} +unsigned char** Perl_Gfold_locale_ptr(pTHX) { + static const unsigned char* fold_locale_ptr = PL_fold_locale; + return (unsigned char**)&fold_locale_ptr; +} +#endif END_EXTERN_C diff --git a/embedvar.h b/embedvar.h index 4496582..b7ce358 100644 --- a/embedvar.h +++ b/embedvar.h @@ -885,39 +885,102 @@ #if defined(PERL_GLOBAL_STRUCT) -#define PL_No (PL_Vars.GNo) -#define PL_Yes (PL_Vars.GYes) -#define PL_csighandlerp (PL_Vars.Gcsighandlerp) -#define PL_curinterp (PL_Vars.Gcurinterp) -#define PL_do_undump (PL_Vars.Gdo_undump) -#define PL_dollarzero_mutex (PL_Vars.Gdollarzero_mutex) -#define PL_hexdigit (PL_Vars.Ghexdigit) -#define PL_malloc_mutex (PL_Vars.Gmalloc_mutex) -#define PL_op_mutex (PL_Vars.Gop_mutex) -#define PL_patleave (PL_Vars.Gpatleave) -#define PL_sh_path (PL_Vars.Gsh_path) -#define PL_sigfpe_saved (PL_Vars.Gsigfpe_saved) -#define PL_sv_placeholder (PL_Vars.Gsv_placeholder) -#define PL_thr_key (PL_Vars.Gthr_key) -#define PL_use_safe_putenv (PL_Vars.Guse_safe_putenv) +#define PL_No (my_vars->GNo) +#define PL_GNo (my_vars->GNo) +#define PL_Yes (my_vars->GYes) +#define PL_GYes (my_vars->GYes) +#define PL_appctx (my_vars->Gappctx) +#define PL_Gappctx (my_vars->Gappctx) +#define PL_check (my_vars->Gcheck) +#define PL_Gcheck (my_vars->Gcheck) +#define PL_csighandlerp (my_vars->Gcsighandlerp) +#define PL_Gcsighandlerp (my_vars->Gcsighandlerp) +#define PL_curinterp (my_vars->Gcurinterp) +#define PL_Gcurinterp (my_vars->Gcurinterp) +#define PL_do_undump (my_vars->Gdo_undump) +#define PL_Gdo_undump (my_vars->Gdo_undump) +#define PL_dollarzero_mutex (my_vars->Gdollarzero_mutex) +#define PL_Gdollarzero_mutex (my_vars->Gdollarzero_mutex) +#define PL_fold_locale (my_vars->Gfold_locale) +#define PL_Gfold_locale (my_vars->Gfold_locale) +#define PL_hexdigit (my_vars->Ghexdigit) +#define PL_Ghexdigit (my_vars->Ghexdigit) +#define PL_malloc_mutex (my_vars->Gmalloc_mutex) +#define PL_Gmalloc_mutex (my_vars->Gmalloc_mutex) +#define PL_mmap_page_size (my_vars->Gmmap_page_size) +#define PL_Gmmap_page_size (my_vars->Gmmap_page_size) +#define PL_op_mutex (my_vars->Gop_mutex) +#define PL_Gop_mutex (my_vars->Gop_mutex) +#define PL_op_seq (my_vars->Gop_seq) +#define PL_Gop_seq (my_vars->Gop_seq) +#define PL_op_sequence (my_vars->Gop_sequence) +#define PL_Gop_sequence (my_vars->Gop_sequence) +#define PL_patleave (my_vars->Gpatleave) +#define PL_Gpatleave (my_vars->Gpatleave) +#define PL_perlio_debug_fd (my_vars->Gperlio_debug_fd) +#define PL_Gperlio_debug_fd (my_vars->Gperlio_debug_fd) +#define PL_perlio_fd_refcnt (my_vars->Gperlio_fd_refcnt) +#define PL_Gperlio_fd_refcnt (my_vars->Gperlio_fd_refcnt) +#define PL_ppaddr (my_vars->Gppaddr) +#define PL_Gppaddr (my_vars->Gppaddr) +#define PL_sh_path (my_vars->Gsh_path) +#define PL_Gsh_path (my_vars->Gsh_path) +#define PL_sig_defaulting (my_vars->Gsig_defaulting) +#define PL_Gsig_defaulting (my_vars->Gsig_defaulting) +#define PL_sig_handlers_initted (my_vars->Gsig_handlers_initted) +#define PL_Gsig_handlers_initted (my_vars->Gsig_handlers_initted) +#define PL_sig_ignoring (my_vars->Gsig_ignoring) +#define PL_Gsig_ignoring (my_vars->Gsig_ignoring) +#define PL_sig_sv (my_vars->Gsig_sv) +#define PL_Gsig_sv (my_vars->Gsig_sv) +#define PL_sig_trapped (my_vars->Gsig_trapped) +#define PL_Gsig_trapped (my_vars->Gsig_trapped) +#define PL_sigfpe_saved (my_vars->Gsigfpe_saved) +#define PL_Gsigfpe_saved (my_vars->Gsigfpe_saved) +#define PL_sv_placeholder (my_vars->Gsv_placeholder) +#define PL_Gsv_placeholder (my_vars->Gsv_placeholder) +#define PL_thr_key (my_vars->Gthr_key) +#define PL_Gthr_key (my_vars->Gthr_key) +#define PL_timesbase (my_vars->Gtimesbase) +#define PL_Gtimesbase (my_vars->Gtimesbase) +#define PL_use_safe_putenv (my_vars->Guse_safe_putenv) +#define PL_Guse_safe_putenv (my_vars->Guse_safe_putenv) +#define PL_watch_pvx (my_vars->Gwatch_pvx) +#define PL_Gwatch_pvx (my_vars->Gwatch_pvx) #else /* !PERL_GLOBAL_STRUCT */ #define PL_GNo PL_No #define PL_GYes PL_Yes +#define PL_Gappctx PL_appctx +#define PL_Gcheck PL_check #define PL_Gcsighandlerp PL_csighandlerp #define PL_Gcurinterp PL_curinterp #define PL_Gdo_undump PL_do_undump #define PL_Gdollarzero_mutex PL_dollarzero_mutex +#define PL_Gfold_locale PL_fold_locale #define PL_Ghexdigit PL_hexdigit #define PL_Gmalloc_mutex PL_malloc_mutex +#define PL_Gmmap_page_size PL_mmap_page_size #define PL_Gop_mutex PL_op_mutex +#define PL_Gop_seq PL_op_seq +#define PL_Gop_sequence PL_op_sequence #define PL_Gpatleave PL_patleave +#define PL_Gperlio_debug_fd PL_perlio_debug_fd +#define PL_Gperlio_fd_refcnt PL_perlio_fd_refcnt +#define PL_Gppaddr PL_ppaddr #define PL_Gsh_path PL_sh_path +#define PL_Gsig_defaulting PL_sig_defaulting +#define PL_Gsig_handlers_initted PL_sig_handlers_initted +#define PL_Gsig_ignoring PL_sig_ignoring +#define PL_Gsig_sv PL_sig_sv +#define PL_Gsig_trapped PL_sig_trapped #define PL_Gsigfpe_saved PL_sigfpe_saved #define PL_Gsv_placeholder PL_sv_placeholder #define PL_Gthr_key PL_thr_key +#define PL_Gtimesbase PL_timesbase #define PL_Guse_safe_putenv PL_use_safe_putenv +#define PL_Gwatch_pvx PL_watch_pvx #endif /* PERL_GLOBAL_STRUCT */ diff --git a/ext/B/B.xs b/ext/B/B.xs index 32556ec..a5aecbb 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -19,7 +19,7 @@ typedef FILE * InputStream; #endif -static char *svclassnames[] = { +static const char* const svclassnames[] = { "B::NULL", "B::IV", "B::NV", @@ -58,7 +58,7 @@ typedef enum { OPc_COP /* 11 */ } opclass; -static char *opclassnames[] = { +static const char* const opclassnames[] = { "B::NULL", "B::OP", "B::UNOP", @@ -73,7 +73,7 @@ static char *opclassnames[] = { "B::COP" }; -static size_t opsizes[] = { +static const size_t opsizes[] = { 0, sizeof(OP), sizeof(UNOP), @@ -211,13 +211,13 @@ cc_opclass(pTHX_ OP *o) static char * cc_opclassname(pTHX_ OP *o) { - return opclassnames[cc_opclass(aTHX_ o)]; + return (char *)opclassnames[cc_opclass(aTHX_ o)]; } static SV * make_sv_object(pTHX_ SV *arg, SV *sv) { - char *type = 0; + const char *type = 0; IV iv; dMY_CXT; @@ -734,7 +734,7 @@ threadsv_names() #define OP_next(o) o->op_next #define OP_sibling(o) o->op_sibling -#define OP_desc(o) PL_op_desc[o->op_type] +#define OP_desc(o) (char *)PL_op_desc[o->op_type] #define OP_targ(o) o->op_targ #define OP_type(o) o->op_type #if PERL_VERSION >= 9 @@ -769,7 +769,7 @@ char * OP_name(o) B::OP o CODE: - RETVAL = PL_op_name[o->op_type]; + RETVAL = (char *)PL_op_name[o->op_type]; OUTPUT: RETVAL diff --git a/ext/ByteLoader/byterun.c b/ext/ByteLoader/byterun.c index 3432eb3..bdc9555 100644 --- a/ext/ByteLoader/byterun.c +++ b/ext/ByteLoader/byterun.c @@ -47,6 +47,7 @@ bset_obj_store(pTHX_ struct byteloader_state *bstate, void *obj, I32 ix) int byterun(pTHX_ register struct byteloader_state *bstate) { + dVAR; register int insn; U32 ix; SV *specialsv_list[6]; @@ -216,7 +217,7 @@ byterun(pTHX_ register struct byteloader_state *bstate) { svindex arg; BGET_svindex(arg); - SvRV(bstate->bs_sv) = arg; + BSET_xrv(bstate->bs_sv, arg); break; } case INSN_XPV: /* 22 */ @@ -228,28 +229,28 @@ byterun(pTHX_ register struct byteloader_state *bstate) { STRLEN arg; BGET_PADOFFSET(arg); - SvCUR(bstate->bs_sv) = arg; + BSET_xpv_cur(bstate->bs_sv, arg); break; } case INSN_XPV_LEN: /* 24 */ { STRLEN arg; BGET_PADOFFSET(arg); - SvLEN(bstate->bs_sv) = arg; + BSET_xpv_len(bstate->bs_sv, arg); break; } case INSN_XIV: /* 25 */ { IV arg; BGET_IV(arg); - SvIVX(bstate->bs_sv) = arg; + BSET_xiv(bstate->bs_sv, arg); break; } case INSN_XNV: /* 26 */ { NV arg; BGET_NV(arg); - SvNVX(bstate->bs_sv) = arg; + BSET_xnv(bstate->bs_sv, arg); break; } case INSN_XLV_TARGOFF: /* 27 */ @@ -592,7 +593,7 @@ byterun(pTHX_ register struct byteloader_state *bstate) { svindex arg; BGET_svindex(arg); - *(SV**)&SvSTASH(bstate->bs_sv) = arg; + bstate->bs_sv = arg; break; } case INSN_GV_FETCHPV: /* 77 */ diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index 0626977..ee1bc14 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -830,8 +830,8 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, SvCUR_set(retval, SvCUR(retval)+i); if (purity) { - static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; - static STRLEN sizes[] = { 8, 7, 6 }; + static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; + static const STRLEN sizes[] = { 8, 7, 6 }; SV *e; SV *nname = newSVpvn("", 0); SV *newapad = newSVpvn("", 0); diff --git a/ext/Digest/MD5/MD5.xs b/ext/Digest/MD5/MD5.xs index 1abe4c4..a89bbd7 100644 --- a/ext/Digest/MD5/MD5.xs +++ b/ext/Digest/MD5/MD5.xs @@ -153,7 +153,7 @@ typedef struct { * padding is also the reason the buffer in MD5_CTX have to be * 128 bytes. */ -static unsigned char PADDING[64] = { +static const unsigned char PADDING[64] = { 0x80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 @@ -484,7 +484,7 @@ static MD5_CTX* get_md5_ctx(pTHX_ SV* sv) static char* hex_16(const unsigned char* from, char* to) { - static char *hexdigits = "0123456789abcdef"; + static const char hexdigits[] = "0123456789abcdef"; const unsigned char *end = from + 16; char *d = to; @@ -499,7 +499,7 @@ static char* hex_16(const unsigned char* from, char* to) static char* base64_16(const unsigned char* from, char* to) { - static char* base64 = + static const char base64[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; const unsigned char *end = from + 16; unsigned char c1, c2, c3; @@ -626,10 +626,18 @@ addfile(self, fh) PREINIT: MD5_CTX* context = get_md5_ctx(aTHX_ self); STRLEN fill = context->bytes_low & 0x3F; +#ifdef USE_HEAP_INSTEAD_OF_STACK + unsigned char* buffer; +#else unsigned char buffer[4096]; +#endif int n; CODE: if (fh) { +#ifdef USE_HEAP_INSTEAD_OF_STACK + New(0, buffer, 4096, unsigned char); + assert(buffer); +#endif if (fill) { /* The MD5Update() function is faster if it can work with * complete blocks. This will fill up any buffered block @@ -646,7 +654,9 @@ addfile(self, fh) while ( (n = PerlIO_read(fh, buffer, sizeof(buffer))) > 0) { MD5Update(context, buffer, n); } - +#ifdef USE_HEAP_INSTEAD_OF_STACK + Safefree(buffer); +#endif if (PerlIO_error(fh)) { croak("Reading from filehandle failed"); } diff --git a/ext/Digest/MD5/t/files.t b/ext/Digest/MD5/t/files.t index 3f18320..615590e 100644 --- a/ext/Digest/MD5/t/files.t +++ b/ext/Digest/MD5/t/files.t @@ -23,7 +23,7 @@ if (ord "A" == 193) { # EBCDIC 15e4c91ad67f5ff238033305376c9140 Changes 0565ec21b15c0f23f4c51fb327c8926d README f0f77710cd8d5ba7d9faedec8d02dc2f MD5.pm -f9848c0ee3b20a9177465eec19361e6c MD5.xs +f6314d62d3aa97dcf4cba66b4c39b105 MD5.xs 276da0aa4e9a08b7fe09430c9c5690aa rfc1321.txt EOT } elsif ("\n" eq "\015") { # MacOS @@ -31,7 +31,7 @@ EOT dea016b088ab4d88a5e7cbd9c15a9c88 Changes 6c950a0211a5a28f023bb482037698cd README f057c88277ecee875cf6f0352468407a MD5.pm -5bae62404829e6fd8ad0d4f8d5ccea54 MD5.xs +a526b0218e43c702a6c994a82620686f MD5.xs 754b9db19f79dbc4992f7166eb0f37ce rfc1321.txt EOT } else { @@ -40,7 +40,7 @@ EOT 0f09886e2c129bdabf57674c6822bd4f Changes 6c950a0211a5a28f023bb482037698cd README f057c88277ecee875cf6f0352468407a MD5.pm -5bae62404829e6fd8ad0d4f8d5ccea54 MD5.xs +a526b0218e43c702a6c994a82620686f MD5.xs 754b9db19f79dbc4992f7166eb0f37ce rfc1321.txt EOT } diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index 8476dad..426d3a5 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -26,6 +26,10 @@ sub to_string { # # -- added by VKON, 03-10-2004 to separate $^O-specific between OSes # (so that Win32 never checks for $^O eq 'VMS' for example) +# +# The $^O tests test both for $^O and for $Config{osname}. +# The latter is better for some for cross-compilation setups. +# sub expand_os_specific { my $s = shift; for ($s) { @@ -36,7 +40,7 @@ sub expand_os_specific { if ($expr =~ m[^(.*?)<<\|\$\^O-$op-$os>>(.*?)$]s) { # #if;#else;#endif my ($if,$el) = ($1,$2); - if (($op eq 'eq' and $^O eq $os) || ($op eq 'ne' and $^O ne $os)) { + if (($op eq 'eq' and ($^O eq $os || $Config{osname} eq $os)) || ($op eq 'ne' and ($^O ne $os || $Config{osname} ne $os))) { $if } else { @@ -45,7 +49,7 @@ sub expand_os_specific { } else { # #if;#endif - if (($op eq 'eq' and $^O eq $os) || ($op eq 'ne' and $^O ne $os)) { + if (($op eq 'eq' and ($^O eq $os || $Config{osname} eq $os)) || ($op eq 'ne' and ($^O ne $os || $Config{osname} ne $os))) { $expr } else { @@ -496,13 +500,22 @@ sub dl_findfile { push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; push(@names, $_); } + my $dirsep = '/'; + <<$^O-eq-symbian>> + $dirsep = '\\'; + if ($0 =~ /^([a-z]):/i) { + my $drive = $1; + @dirs = map { "$drive:$_" } @dirs; + @dl_library_path = map { "$drive:$_" } @dl_library_path; + } + <> foreach $dir (@dirs, @dl_library_path) { next unless -d $dir; <<$^O-eq-VMS>> chop($dir = VMS::Filespec::unixpath($dir)); <> foreach $name (@names) { - my($file) = "$dir/$name"; + my($file) = "$dir$dirsep$name"; print STDERR " checking in $dir for $name\n" if $dl_debug; $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); #$file = _check_file($file); diff --git a/ext/DynaLoader/dl_symbian.xs b/ext/DynaLoader/dl_symbian.xs new file mode 100644 index 0000000..6cf1d1f --- /dev/null +++ b/ext/DynaLoader/dl_symbian.xs @@ -0,0 +1,223 @@ +/* dl_symbian.xs + * + * Platform: Symbian 7.0s + * Author: Jarkko Hietaniemi + * Copyright: 2004, Nokia + * License: Artistic/GPL + * + */ + +/* + * In Symbian DLLs there is no name information, one can only access + * the functions by their ordinals. Perl, however, very much would like + * to load functions by their names. We fake this by having a special + * setup function at the ordinal 1 (this is arranged by building the DLLs + * in a special way). The setup function builds a Perl hash mapping the + * names to the ordinals, and the hash is then used by dlsym(). + * + */ + +#include +#include +#include + +/* This is a useful pattern: first include the Symbian headers, + * only after that the Perl ones. Otherwise you will get a lot + * trouble because of Symbian's New(), Copy(), etc definitions. */ + +#define DL_SYMBIAN_XS + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +START_EXTERN_C + +void *dlopen(const char *filename, int flag); +void *dlsym(void *handle, const char *symbol); +int dlclose(void *handle); +const char *dlerror(void); + +extern void* memset(void *s, int c, size_t n); +extern size_t strlen(const char *s); + +END_EXTERN_C + +#include "dlutils.c" + +#define RTLD_LAZY 0x0001 +#define RTLD_NOW 0x0002 +#define RTLD_GLOBAL 0x0004 + +#ifndef NULL +# define NULL 0 +#endif + +/* No need to pull in symbian_dll.cpp for this. */ +#define symbian_get_vars() ((void*)Dll::Tls()) + +const TInt KPerlDllSetupFunction = 1; + +typedef struct { + RLibrary handle; + TInt error; + HV* symbols; +} PerlSymbianLibHandle; + +typedef void (*PerlSymbianLibInit)(void *); + +void* dlopen(const char *filename, int flags) { + TBuf16 utf16fn; + const TUint8* utf8fn = (const TUint8*)filename; + PerlSymbianLibHandle* h = NULL; + TInt error; + + error = + CnvUtfConverter::ConvertToUnicodeFromUtf8(utf16fn, TPtrC8(utf8fn)); + if (error == KErrNone) { + h = new PerlSymbianLibHandle; + if (h) { + h->error = KErrNone; + h->symbols = Nullhv; + } else + error = KErrNoMemory; + } + + if (h && error == KErrNone) { + error = (h->handle).Load(utf16fn); + if (error == KErrNone) { + TLibraryFunction init = (h->handle).Lookup(KPerlDllSetupFunction); + ((PerlSymbianLibInit)init)(h); + } else { + free(h); + h = NULL; + } + } + + if (h) + h->error = error; + + return h; +} + +void* dlsym(void *handle, const char *symbol) { + if (handle) { + dTHX; + PerlSymbianLibHandle* h = (PerlSymbianLibHandle*)handle; + HV* symbols = h->symbols; + if (symbols) { + SV** svp = hv_fetch(symbols, symbol, strlen(symbol), FALSE); + if (svp && *svp && SvIOK(*svp)) { + IV ord = SvIV(*svp); + if (ord > 0) + return (void*)((h->handle).Lookup(ord)); + } + } + } + return NULL; +} + +int dlclose(void *handle) { + PerlSymbianLibHandle* h = (PerlSymbianLibHandle*)handle; + if (h) { + (h->handle).Close(); + if (h->symbols) { + dTHX; + hv_undef(h->symbols); + h->symbols = NULL; + } + return 0; + } else + return 1; +} + +const char* dlerror(void) { + return 0; /* Bad interface: assumes static data. */ +} + +static void +dl_private_init(pTHX) +{ + (void)dl_generic_private_init(aTHX); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +PROTOTYPES: ENABLE + +BOOT: + (void)dl_private_init(aTHX); + + +void +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + PerlSymbianLibHandle* h; + CODE: +{ + ST(0) = sv_newmortal(); + h = (PerlSymbianLibHandle*)dlopen(filename, flags); + if (h && h->error == KErrNone) + sv_setiv(ST(0), PTR2IV(h)); + else + PerlIO_printf(Perl_debug_log, "(dl_load_file %s %d)", + filename, h ? h->error : -1); +} + + +int +dl_unload_file(libhandle) + void * libhandle + CODE: + RETVAL = (dlclose(libhandle) == 0 ? 1 : 0); + OUTPUT: + RETVAL + + +void +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + PREINIT: + void *sym; + CODE: + PerlSymbianLibHandle* h = (PerlSymbianLibHandle*)libhandle; + sym = dlsym(libhandle, symbolname); + ST(0) = sv_newmortal(); + if (sym) + sv_setiv(ST(0), PTR2IV(sym)); + else + PerlIO_printf(Perl_debug_log, "(dl_find_symbol %s %d)", + symbolname, h ? h->error : -1); + + +void +dl_undef_symbols() + CODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); + + +char * +dl_error() + CODE: + dMY_CXT; + RETVAL = dl_last_error; + OUTPUT: + RETVAL + +# end. diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 474c93d..956848a 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -8,6 +8,12 @@ * files when the interpreter exits */ +#ifndef START_MY_CXT /* Some IDEs try compiling this standalone. */ +# include "EXTERN.h" +# include "perl.h" +# include "XSUB.h" +#endif + #ifndef XS_VERSION # define XS_VERSION "0" #endif @@ -110,6 +116,7 @@ dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */ } +#ifndef SYMBIAN /* SaveError() takes printf style args and saves the result in dl_last_error */ static void SaveError(pTHX_ const char* pat, ...) @@ -133,4 +140,5 @@ SaveError(pTHX_ const char* pat, ...) sv_setpvn(MY_CXT.x_dl_last_error, message, len) ; DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error)); } +#endif diff --git a/ext/Errno/Errno_pm.PL b/ext/Errno/Errno_pm.PL index 39e2c19..5c76d89 100644 --- a/ext/Errno/Errno_pm.PL +++ b/ext/Errno/Errno_pm.PL @@ -7,6 +7,11 @@ our $VERSION = "1.09_01"; my %err = (); my %wsa = (); +# Symbian cross-compiling environment. +my $IsSymbian = exists $ENV{SDK} && -d "$ENV{SDK}\\epoc32"; + +my $IsMSWin32 = $^O eq 'MSWin32' && !$IsSymbian; + unlink "Errno.pm" if -f "Errno.pm"; open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!"; select OUT; @@ -27,7 +32,7 @@ sub process_file { } return unless defined $file and -f $file; -# warn "Processing $file\n"; +# warn "Processing $file\n"; local *FH; if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) { @@ -53,7 +58,7 @@ sub process_file { return; } } - + if ($^O eq 'MacOS') { while() { $err{$1} = $2 @@ -63,12 +68,13 @@ sub process_file { while() { $err{$1} = 1 if /^\s*#\s*define\s+(E\w+)\s+/; - if ($^O eq 'MSWin32') { + if ($IsMSWin32) { $wsa{$1} = 1 if /^\s*#\s*define\s+WSA(E\w+)\s+/; } } } + close(FH); } @@ -130,6 +136,10 @@ sub get_files { } elsif ($^O eq 'vos') { # avoid problem where cpp returns non-POSIX pathnames $file{'/system/include_library/errno.h'} = 1; + } elsif ($IsSymbian) { + my $SDK = $ENV{SDK}; + $SDK =~ s!\\!/!g; + $file{"$SDK/epoc32/include/libc/sys/errno.h"} = 1; } else { open(CPPI,"> errno.c") or die "Cannot open errno.c"; @@ -138,7 +148,7 @@ sub get_files { print CPPI "#include \n"; } else { print CPPI "#include \n"; - if ($^O eq 'MSWin32') { + if ($IsMSWin32) { print CPPI "#define _WINSOCKAPI_\n"; # don't drag in everything print CPPI "#include \n"; } @@ -147,7 +157,7 @@ sub get_files { close(CPPI); # invoke CPP and read the output - if ($^O eq 'MSWin32' || $^O eq 'NetWare') { + if ($IsMSWin32 || $^O eq 'NetWare') { open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; } else { @@ -157,14 +167,14 @@ sub get_files { } my $pat; - if (($^O eq 'MSWin32' || $^O eq 'NetWare') and $Config{cc} =~ /^bcc/i) { + if (($IsMSWin32 || $^O eq 'NetWare') and $Config{cc} =~ /^bcc/i) { $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/'; } else { $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"'; } while() { - if ($^O eq 'os2' or $^O eq 'MSWin32' or $^O eq 'NetWare') { + if ($^O eq 'os2' or $IsMSWin32 or $^O eq 'NetWare') { if (/$pat/o) { my $f = $1; $f =~ s,\\\\,/,g; @@ -198,7 +208,7 @@ sub write_errno_pm { else { print CPPI "#include \n"; } - if ($^O eq 'MSWin32') { + if ($IsMSWin32) { print CPPI "#include \n"; foreach $err (keys %wsa) { print CPPI "#ifndef $err\n"; @@ -222,10 +232,14 @@ sub write_errno_pm { $cpp =~ s/sys\$input//i; open(CPPO,"$cpp errno.c |") or die "Cannot exec $Config{cppstdin}"; - } elsif ($^O eq 'MSWin32' || $^O eq 'NetWare') { + } elsif ($IsMSWin32 || $^O eq 'NetWare') { open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; - } else { + } elsif ($IsSymbian) { + my $cpp = "gcc -E -I$ENV{SDK}\\epoc32\\include\\libc -"; + open(CPPO,"$cpp < errno.c |") + or die "Cannot exec $cpp"; + } else { my $cpp = default_cpp(); open(CPPO,"$cpp < errno.c |") or die "Cannot exec $cpp"; diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index e706894..353785a 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -19,7 +19,7 @@ use Errno; # legacy require IO::Socket::INET; -require IO::Socket::UNIX if ($^O ne 'epoc'); +require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); @ISA = qw(IO::Handle); diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs index 3a03488..790a2b9 100644 --- a/ext/List/Util/Util.xs +++ b/ext/List/Util/Util.xs @@ -103,6 +103,24 @@ sv_tainted(SV *sv) # define PTR2UV(ptr) (UV)(ptr) #endif +#ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +#else +# define PERL_UNUSED_DECL +#endif + +#ifndef dNOOP +#define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef dVAR +#define dVAR dNOOP +#endif + MODULE=List::Util PACKAGE=List::Util void @@ -206,6 +224,7 @@ reduce(block,...) PROTOTYPE: &@ CODE: { + dVAR; SV *ret = sv_newmortal(); int index; GV *agv,*bgv,*gv; @@ -261,6 +280,7 @@ first(block,...) PROTOTYPE: &@ CODE: { + dVAR; int index; GV *gv; HV *stash; @@ -315,6 +335,7 @@ shuffle(...) PROTOTYPE: @ CODE: { + dVAR; int index; struct op dmy_op; struct op *old_op = PL_op; diff --git a/ext/MIME/Base64/Base64.xs b/ext/MIME/Base64/Base64.xs index 8fd14cf..99ff0e4 100644 --- a/ext/MIME/Base64/Base64.xs +++ b/ext/MIME/Base64/Base64.xs @@ -56,14 +56,14 @@ extern "C" { #define MAX_LINE 76 /* size of encoded lines */ -static char basis_64[] = +static const char basis_64[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; #define XX 255 /* illegal base64 char */ #define EQ 254 /* padding */ #define INVALID XX -static unsigned char index_64[256] = { +static const unsigned char index_64[256] = { XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,62, XX,XX,XX,63, diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 561dc30..9f76b47 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -85,6 +85,24 @@ char *tzname[] = { "" , "" }; #endif #endif +#ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +#else +# define PERL_UNUSED_DECL +#endif + +#ifndef dNOOP +#define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef dVAR +#define dVAR dNOOP +#endif + #if defined(__VMS) && !defined(__POSIX_SOURCE) # include /* LIB$_INVARG constant */ # include /* prototype for lib$ediv() */ @@ -189,7 +207,9 @@ char *tzname[] = { "" , "" }; # define ttyname(a) (char*)not_here("ttyname") # define tzset() not_here("tzset") # else -# include +# ifdef I_GRP +# include +# endif # include # ifdef HAS_UNAME # include @@ -602,7 +622,6 @@ sigismember(sigset, sig) POSIX::SigSet sigset int sig - MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf POSIX::Termios @@ -1228,6 +1247,7 @@ sigaction(sig, optaction, oldaction = 0) # interface look beautiful, which is hard. { + dVAR; POSIX__SigAction action; GV *siggv = gv_fetchpv("SIG", TRUE, SVt_PVHV); struct sigaction act; diff --git a/ext/PerlIO/scalar/scalar.xs b/ext/PerlIO/scalar/scalar.xs index 074da92..55a5fd8 100644 --- a/ext/PerlIO/scalar/scalar.xs +++ b/ext/PerlIO/scalar/scalar.xs @@ -254,7 +254,7 @@ PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, return f; } -PerlIO_funcs PerlIO_scalar = { +PERLIO_FUNCS_DECL(PerlIO_scalar) = { sizeof(PerlIO_funcs), "scalar", sizeof(PerlIOScalar), @@ -295,7 +295,7 @@ PROTOTYPES: ENABLE BOOT: { #ifdef PERLIO_LAYERS - PerlIO_define_layer(aTHX_ &PerlIO_scalar); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar)); #endif } diff --git a/ext/PerlIO/via/via.xs b/ext/PerlIO/via/via.xs index d95d631..ad27416 100644 --- a/ext/PerlIO/via/via.xs +++ b/ext/PerlIO/via/via.xs @@ -590,7 +590,7 @@ PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, -PerlIO_funcs PerlIO_object = { +PERLIO_FUNCS_DECL(PerlIO_object) = { sizeof(PerlIO_funcs), "via", sizeof(PerlIOVia), @@ -630,7 +630,7 @@ PROTOTYPES: ENABLE; BOOT: { #ifdef PERLIO_LAYERS - PerlIO_define_layer(aTHX_ &PerlIO_object); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_object)); #endif } diff --git a/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index a3c4acf..f705db5 100644 --- a/ext/SDBM_File/sdbm/sdbm.c +++ b/ext/SDBM_File/sdbm/sdbm.c @@ -62,7 +62,7 @@ static int makroom proto((DBM *, long, int)); #define OFF_PAG(off) (long) (off) * PBLKSIZ #define OFF_DIR(off) (long) (off) * DBLKSIZ -static long masks[] = { +static const long masks[] = { 000000000000, 000000000001, 000000000003, 000000000007, 000000000017, 000000000037, 000000000077, 000000000177, 000000000377, 000000000777, 000000001777, 000000003777, diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 702644e..7c6a755 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -93,6 +93,24 @@ typedef double NV; /* Older perls lack the NV type */ #endif #endif +#ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +#else +# define PERL_UNUSED_DECL +#endif + +#ifndef dNOOP +#define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef dVAR +#define dVAR dNOOP +#endif + #ifdef DEBUGME #ifndef DASSERT @@ -1024,15 +1042,17 @@ static int store_code(pTHX_ stcxt_t *cxt, CV *cv); static int store_other(pTHX_ stcxt_t *cxt, SV *sv); static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg); -static int (*sv_store[])(pTHX_ stcxt_t *cxt, SV *sv) = { - store_ref, /* svis_REF */ - store_scalar, /* svis_SCALAR */ - (int (*)(pTHX_ stcxt_t *cxt, SV *sv)) store_array, /* svis_ARRAY */ - (int (*)(pTHX_ stcxt_t *cxt, SV *sv)) store_hash, /* svis_HASH */ - store_tied, /* svis_TIED */ - store_tied_item, /* svis_TIED_ITEM */ - (int (*)(pTHX_ stcxt_t *cxt, SV *sv)) store_code, /* svis_CODE */ - store_other, /* svis_OTHER */ +#define SV_STORE_TYPE (const int (* const)(pTHX_ stcxt_t *cxt, SV *sv)) + +static const int (* const sv_store[])(pTHX_ stcxt_t *cxt, SV *sv) = { + SV_STORE_TYPE store_ref, /* svis_REF */ + SV_STORE_TYPE store_scalar, /* svis_SCALAR */ + SV_STORE_TYPE store_array, /* svis_ARRAY */ + SV_STORE_TYPE store_hash, /* svis_HASH */ + SV_STORE_TYPE store_tied, /* svis_TIED */ + SV_STORE_TYPE store_tied_item, /* svis_TIED_ITEM */ + SV_STORE_TYPE store_code, /* svis_CODE */ + SV_STORE_TYPE store_other, /* svis_OTHER */ }; #define SV_STORE(x) (*sv_store[x]) @@ -1058,37 +1078,39 @@ static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, char *cname); static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, char *cname); static SV *retrieve_other(pTHX_ stcxt_t *cxt, char *cname); -static SV *(*sv_old_retrieve[])(pTHX_ stcxt_t *cxt, char *cname) = { - 0, /* SX_OBJECT -- entry unused dynamically */ - retrieve_lscalar, /* SX_LSCALAR */ - old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ - old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */ - retrieve_ref, /* SX_REF */ - retrieve_undef, /* SX_UNDEF */ - retrieve_integer, /* SX_INTEGER */ - retrieve_double, /* SX_DOUBLE */ - retrieve_byte, /* SX_BYTE */ - retrieve_netint, /* SX_NETINT */ - retrieve_scalar, /* SX_SCALAR */ - retrieve_tied_array, /* SX_ARRAY */ - retrieve_tied_hash, /* SX_HASH */ - retrieve_tied_scalar, /* SX_SCALAR */ - retrieve_other, /* SX_SV_UNDEF not supported */ - retrieve_other, /* SX_SV_YES not supported */ - retrieve_other, /* SX_SV_NO not supported */ - retrieve_other, /* SX_BLESS not supported */ - retrieve_other, /* SX_IX_BLESS not supported */ - retrieve_other, /* SX_HOOK not supported */ - retrieve_other, /* SX_OVERLOADED not supported */ - retrieve_other, /* SX_TIED_KEY not supported */ - retrieve_other, /* SX_TIED_IDX not supported */ - retrieve_other, /* SX_UTF8STR not supported */ - retrieve_other, /* SX_LUTF8STR not supported */ - retrieve_other, /* SX_FLAG_HASH not supported */ - retrieve_other, /* SX_CODE not supported */ - retrieve_other, /* SX_WEAKREF not supported */ - retrieve_other, /* SX_WEAKOVERLOAD not supported */ - retrieve_other, /* SX_ERROR */ +#define SV_RETRIEVE_TYPE (const SV* (* const)(pTHX_ stcxt_t *cxt, char *cname)) + +static const SV *(* const sv_old_retrieve[])(pTHX_ stcxt_t *cxt, char *cname) = { + 0, /* SX_OBJECT -- entry unused dynamically */ + SV_RETRIEVE_TYPE retrieve_lscalar, /* SX_LSCALAR */ + SV_RETRIEVE_TYPE old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ + SV_RETRIEVE_TYPE old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */ + SV_RETRIEVE_TYPE retrieve_ref, /* SX_REF */ + SV_RETRIEVE_TYPE retrieve_undef, /* SX_UNDEF */ + SV_RETRIEVE_TYPE retrieve_integer, /* SX_INTEGER */ + SV_RETRIEVE_TYPE retrieve_double, /* SX_DOUBLE */ + SV_RETRIEVE_TYPE retrieve_byte, /* SX_BYTE */ + SV_RETRIEVE_TYPE retrieve_netint, /* SX_NETINT */ + SV_RETRIEVE_TYPE retrieve_scalar, /* SX_SCALAR */ + SV_RETRIEVE_TYPE retrieve_tied_array, /* SX_ARRAY */ + SV_RETRIEVE_TYPE retrieve_tied_hash, /* SX_HASH */ + SV_RETRIEVE_TYPE retrieve_tied_scalar, /* SX_SCALAR */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_SV_UNDEF not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_SV_YES not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_SV_NO not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_BLESS not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_IX_BLESS not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_HOOK not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_OVERLOADED not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_TIED_KEY not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_TIED_IDX not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_UTF8STR not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_LUTF8STR not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_FLAG_HASH not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_CODE not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_WEAKREF not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_WEAKOVERLOAD not supported */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_ERROR */ }; static SV *retrieve_array(pTHX_ stcxt_t *cxt, char *cname); @@ -1107,37 +1129,37 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, char *cname); static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, char *cname); static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, char *cname); -static SV *(*sv_retrieve[])(pTHX_ stcxt_t *cxt, char *cname) = { +static const SV *(* const sv_retrieve[])(pTHX_ stcxt_t *cxt, char *cname) = { 0, /* SX_OBJECT -- entry unused dynamically */ - retrieve_lscalar, /* SX_LSCALAR */ - retrieve_array, /* SX_ARRAY */ - retrieve_hash, /* SX_HASH */ - retrieve_ref, /* SX_REF */ - retrieve_undef, /* SX_UNDEF */ - retrieve_integer, /* SX_INTEGER */ - retrieve_double, /* SX_DOUBLE */ - retrieve_byte, /* SX_BYTE */ - retrieve_netint, /* SX_NETINT */ - retrieve_scalar, /* SX_SCALAR */ - retrieve_tied_array, /* SX_ARRAY */ - retrieve_tied_hash, /* SX_HASH */ - retrieve_tied_scalar, /* SX_SCALAR */ - retrieve_sv_undef, /* SX_SV_UNDEF */ - retrieve_sv_yes, /* SX_SV_YES */ - retrieve_sv_no, /* SX_SV_NO */ - retrieve_blessed, /* SX_BLESS */ - retrieve_idx_blessed, /* SX_IX_BLESS */ - retrieve_hook, /* SX_HOOK */ - retrieve_overloaded, /* SX_OVERLOAD */ - retrieve_tied_key, /* SX_TIED_KEY */ - retrieve_tied_idx, /* SX_TIED_IDX */ - retrieve_utf8str, /* SX_UTF8STR */ - retrieve_lutf8str, /* SX_LUTF8STR */ - retrieve_flag_hash, /* SX_HASH */ - retrieve_code, /* SX_CODE */ - retrieve_weakref, /* SX_WEAKREF */ - retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */ - retrieve_other, /* SX_ERROR */ + SV_RETRIEVE_TYPE retrieve_lscalar, /* SX_LSCALAR */ + SV_RETRIEVE_TYPE retrieve_array, /* SX_ARRAY */ + SV_RETRIEVE_TYPE retrieve_hash, /* SX_HASH */ + SV_RETRIEVE_TYPE retrieve_ref, /* SX_REF */ + SV_RETRIEVE_TYPE retrieve_undef, /* SX_UNDEF */ + SV_RETRIEVE_TYPE retrieve_integer, /* SX_INTEGER */ + SV_RETRIEVE_TYPE retrieve_double, /* SX_DOUBLE */ + SV_RETRIEVE_TYPE retrieve_byte, /* SX_BYTE */ + SV_RETRIEVE_TYPE retrieve_netint, /* SX_NETINT */ + SV_RETRIEVE_TYPE retrieve_scalar, /* SX_SCALAR */ + SV_RETRIEVE_TYPE retrieve_tied_array, /* SX_ARRAY */ + SV_RETRIEVE_TYPE retrieve_tied_hash, /* SX_HASH */ + SV_RETRIEVE_TYPE retrieve_tied_scalar, /* SX_SCALAR */ + SV_RETRIEVE_TYPE retrieve_sv_undef, /* SX_SV_UNDEF */ + SV_RETRIEVE_TYPE retrieve_sv_yes, /* SX_SV_YES */ + SV_RETRIEVE_TYPE retrieve_sv_no, /* SX_SV_NO */ + SV_RETRIEVE_TYPE retrieve_blessed, /* SX_BLESS */ + SV_RETRIEVE_TYPE retrieve_idx_blessed, /* SX_IX_BLESS */ + SV_RETRIEVE_TYPE retrieve_hook, /* SX_HOOK */ + SV_RETRIEVE_TYPE retrieve_overloaded, /* SX_OVERLOAD */ + SV_RETRIEVE_TYPE retrieve_tied_key, /* SX_TIED_KEY */ + SV_RETRIEVE_TYPE retrieve_tied_idx, /* SX_TIED_IDX */ + SV_RETRIEVE_TYPE retrieve_utf8str, /* SX_UTF8STR */ + SV_RETRIEVE_TYPE retrieve_lutf8str, /* SX_LUTF8STR */ + SV_RETRIEVE_TYPE retrieve_flag_hash, /* SX_HASH */ + SV_RETRIEVE_TYPE retrieve_code, /* SX_CODE */ + SV_RETRIEVE_TYPE retrieve_weakref, /* SX_WEAKREF */ + SV_RETRIEVE_TYPE retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */ + SV_RETRIEVE_TYPE retrieve_other, /* SX_ERROR */ }; #define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)]) @@ -2161,6 +2183,7 @@ sortcmp(const void *a, const void *b) */ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) { + dVAR; I32 len = #ifdef HAS_RESTRICTED_HASHES HvTOTALKEYS(hv); @@ -2250,7 +2273,7 @@ static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) for (i = 0; i < len; i++) { #ifdef HAS_RESTRICTED_HASHES - int placeholders = HvPLACEHOLDERS(hv); + int placeholders = (int)HvPLACEHOLDERS(hv); #endif unsigned char flags = 0; char *keyval; @@ -3235,7 +3258,7 @@ static int store_blessed( static int store_other(pTHX_ stcxt_t *cxt, SV *sv) { I32 len; - static char buf[80]; + char buf[80]; TRACEME(("store_other")); @@ -5050,6 +5073,7 @@ static SV *retrieve_hash(pTHX_ stcxt_t *cxt, char *cname) */ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, char *cname) { + dVAR; I32 len; I32 size; I32 i; @@ -5373,7 +5397,7 @@ static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, char *cname) HV *hv; SV *sv = (SV *) 0; int c; - static SV *sv_h_undef = (SV *) 0; /* hv_store() bug */ + SV *sv_h_undef = (SV *) 0; /* hv_store() bug */ TRACEME(("old_retrieve_hash (#%d)", cxt->tagnum)); @@ -5524,7 +5548,7 @@ static SV *magic_check(pTHX_ stcxt_t *cxt) */ version_major = use_network_order >> 1; - cxt->retrieve_vtbl = version_major ? sv_retrieve : sv_old_retrieve; + cxt->retrieve_vtbl = (SV*(**)()) (version_major ? sv_retrieve : sv_old_retrieve); TRACEME(("magic_check: netorder = 0x%x", use_network_order)); diff --git a/ext/Time/HiRes/HiRes.xs b/ext/Time/HiRes/HiRes.xs index 3272748..b9040eb 100644 --- a/ext/Time/HiRes/HiRes.xs +++ b/ext/Time/HiRes/HiRes.xs @@ -31,6 +31,7 @@ extern "C" { #ifdef HAS_PAUSE # define Pause pause #else +# undef Pause /* In case perl.h did it already. */ # define Pause() sleep(~0) /* Zzz for a long time. */ #endif diff --git a/global.sym b/global.sym index 3624874..3887879 100644 --- a/global.sym +++ b/global.sym @@ -675,3 +675,5 @@ Perl_hv_scalar Perl_gv_fetchpvn_flags Perl_gv_fetchsv Perl_savesvpv +Perl_init_global_struct +Perl_free_global_struct diff --git a/globvar.sym b/globvar.sym index 0d76888..2e528e3 100644 --- a/globvar.sym +++ b/globvar.sym @@ -1,68 +1,72 @@ # Global variables that must be exported for embedded applications. - +# *** Do NOT add functions here, those go in global.sym. # *** Only structures/arrays with constant initializers should go here. # *** Usual globals initialized at runtime should be added in *var*.h. -# *** Do NOT add functions here, those go in global.sym. AMG_names block_type +check fold fold_locale freq -warn_uninit -warn_nosemi -warn_reserved -warn_nl -no_wrongref -no_symref -no_usym +memory_wrap no_aelem +no_dir_func +no_func no_helem -no_modify +no_localize_ref no_mem +no_modify +no_myglob no_security no_sock_func -no_dir_func -no_func -no_myglob -check +no_symref +no_usym +no_wrongref op_desc op_name opargs ppaddr +regkind sig_name sig_num -regkind simple utf8skip uuemap varies -vtbl_sv +vtbl_amagic +vtbl_amagicelem +vtbl_arylen +vtbl_backref +vtbl_bm +vtbl_collxfrm +vtbl_dbline +vtbl_defelem vtbl_env vtbl_envelem -vtbl_sig -vtbl_sigelem -vtbl_pack -vtbl_packelem -vtbl_dbline +vtbl_fm +vtbl_glob vtbl_isa vtbl_isaelem -vtbl_arylen -vtbl_glob vtbl_mglob +vtbl_mutex vtbl_nkeys -vtbl_taint -vtbl_substr -vtbl_vec +vtbl_pack +vtbl_packelem vtbl_pos -vtbl_bm -vtbl_fm -vtbl_uvar -vtbl_mutex -vtbl_defelem -vtbl_regexp vtbl_regdata vtbl_regdatum -vtbl_collxfrm -vtbl_amagic -vtbl_amagicelem +vtbl_regexp +vtbl_sig +vtbl_sigelem +vtbl_substr +vtbl_sv +vtbl_taint +vtbl_utf8 +vtbl_uvar +vtbl_vec +warn_nl +warn_nosemi +warn_reserved +warn_uninit +watch_pvx diff --git a/gv.c b/gv.c index 8ad546d..8ea4171 100644 --- a/gv.c +++ b/gv.c @@ -105,6 +105,7 @@ Perl_gv_fetchfile(pTHX_ const char *name) void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { + dVAR; register GP *gp; const bool doproto = SvTYPE(gv) > SVt_NULL; char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; @@ -482,6 +483,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { + dVAR; char autoload[] = "AUTOLOAD"; STRLEN autolen = sizeof(autoload)-1; GV* gv; @@ -557,6 +559,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) STATIC void S_require_errno(pTHX_ GV *gv) { + dVAR; HV* stash = gv_stashpvn("Errno",5,FALSE); if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { @@ -1497,6 +1500,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { + dVAR; MAGIC *mg; CV *cv=NULL; CV **cvp=NULL, **ocvp=NULL; diff --git a/hv.c b/hv.c index 8c6ec39..8345ee5 100644 --- a/hv.c +++ b/hv.c @@ -383,6 +383,7 @@ STATIC HE * S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int flags, int action, SV *val, register U32 hash) { + dVAR; XPVHV* xhv; U32 n_links; HE *entry; @@ -882,6 +883,7 @@ STATIC SV * S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int k_flags, I32 d_flags, U32 hash) { + dVAR; register XPVHV* xhv; register I32 i; register HE *entry; @@ -1442,6 +1444,7 @@ Clears a hash, making it empty. void Perl_hv_clear(pTHX_ HV *hv) { + dVAR; register XPVHV* xhv; if (!hv) return; @@ -1506,6 +1509,7 @@ See Hash::Util::lock_keys() for an example of its use. void Perl_hv_clear_placeholders(pTHX_ HV *hv) { + dVAR; I32 items = (I32)HvPLACEHOLDERS(hv); I32 i = HvMAX(hv); @@ -1696,6 +1700,7 @@ insufficiently abstracted for any change to be tidy. HE * Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) { + dVAR; register XPVHV* xhv; register HE *entry; HE *oldentry; @@ -2137,6 +2142,7 @@ Check that a hash is in an internally consistent state. void Perl_hv_assert(pTHX_ HV *hv) { + dVAR; HE* entry; int withflags = 0; int placeholders = 0; diff --git a/intrpvar.h b/intrpvar.h index 3159b28..3fe5adb 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -29,7 +29,7 @@ PERLVAR(Iwarnhook, SV *) /* switches */ PERLVAR(Iminus_c, bool) PERLVAR(Ipatchlevel, SV *) -PERLVAR(Ilocalpatches, const char **) +PERLVAR(Ilocalpatches, const char * const *) PERLVARI(Isplitstr, const char *, " ") PERLVAR(Ipreprocess, bool) PERLVAR(Iminus_n, bool) diff --git a/lib/ExtUtils/t/Embed.t b/lib/ExtUtils/t/Embed.t index fc0ed3c..1c82cd9 100644 --- a/lib/ExtUtils/t/Embed.t +++ b/lib/ExtUtils/t/Embed.t @@ -153,10 +153,22 @@ __END__ static char *cmds[] = { "perl","-e", "$|=1; print qq[ok 5\\n]", NULL }; +#ifdef PERL_GLOBAL_STRUCT_PRIVATE +static struct perl_vars *my_plvarsp; +struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; } +#endif + int main(int argc, char **argv, char **env) { PerlInterpreter *my_perl; - +#ifdef PERL_GLOBAL_STRUCT + dVAR; + struct perl_vars *plvarsp = init_global_struct(); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + my_vars = my_plvarsp = plvarsp; +# endif +#endif /* PERL_GLOBAL_STRUCT */ + PERL_SYS_INIT3(&argc,&argv,&env); my_perl = perl_alloc(); @@ -183,6 +195,10 @@ int main(int argc, char **argv, char **env) perl_free(my_perl); +#ifdef PERL_GLOBAL_STRUCT + free_global_struct(plvarsp); +#endif /* PERL_GLOBAL_STRUCT */ + my_puts("ok 8"); PERL_SYS_TERM(); diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 7ae8020..9be40e6 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -6,7 +6,7 @@ xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS -B [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs +B [B<-v>] [B<-C++>] [B<-csuffix csuffix>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs =head1 DESCRIPTION @@ -34,6 +34,12 @@ any makefiles generated by MakeMaker. Adds ``extern "C"'' to the C code. +=item B<-csuffix csuffix> + +Set the suffix used for the generated C or C++ code. Defaults to '.c' +(even with B<-C++>), but some platforms might want to have e.g. '.cpp'. +Don't forget the '.' from the front. + =item B<-hiertype> Retains '::' in type names so that C++ hierachical types can be mapped. @@ -126,7 +132,7 @@ if ($^O eq 'VMS') { $FH = 'File0000' ; -$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; +$usage = "Usage: xsubpp [-v] [-C++] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ; @@ -141,12 +147,14 @@ $Fallback = 'PL_sv_undef'; my $process_inout = 1; my $process_argtypes = 1; +my $csuffix = '.c'; SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { $flag = shift @ARGV; $flag =~ s/^-// ; $spat = quotemeta shift, next SWITCH if $flag eq 's'; $cplusplus = 1, next SWITCH if $flag eq 'C++'; + $csuffix = shift, next SWITCH if $flag eq 'csuffix'; $hiertype = 1, next SWITCH if $flag eq 'hiertype'; $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; @@ -357,7 +365,7 @@ if ($WantLineNumbers) { } my $cfile = $filename; - $cfile =~ s/\.xs$/.c/i or $cfile .= ".c"; + $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix; tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); select PSEUDO_STDOUT; } @@ -1059,6 +1067,7 @@ while (fetch_para()) { undef(%var_types); undef(%defaults); undef($class); + undef($externC); undef($static); undef($elipsis); undef($wantRETVAL) ; @@ -1112,7 +1121,8 @@ while (fetch_para()) { blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH unless @line ; - $static = 1 if $ret_type =~ s/^static\s+//; + $externC = 1 if $ret_type =~ s/^extern "C"\s+//; + $static = 1 if $ret_type =~ s/^static\s+//; $func_header = shift(@line); blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH @@ -1251,8 +1261,11 @@ while (fetch_para()) { $xsreturn = 1 if $EXPLICIT_RETURN; + $externC = $externC ? qq[extern "C"] : ""; + # print function header print Q<<"EOF"; +#$externC #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ #XS(XS_${Full_func_name}) #[[ diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index e1986a9..7cb7192 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -12,6 +12,7 @@ my %module = (MacOS => 'Mac', VMS => 'VMS', epoc => 'Epoc', NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. + symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. cygwin => 'Cygwin'); diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index de560ce..e5d3810 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -44,12 +44,13 @@ from the following list: $ENV{TEMP} $ENV{TMP} SYS:/temp + C:\system\temp C:/temp /tmp / -The SYS:/temp is preferred in Novell NetWare (the File::Spec::Win32 -is used also for NetWare). +The SYS:/temp is preferred in Novell NetWare and the C:\system\temp +for Symbian (the File::Spec::Win32 is used also for those platforms). Since Perl 5.8.0, if running under taint mode, and if the environment variables are tainted, they are not used. @@ -62,6 +63,7 @@ sub tmpdir { my $self = shift; $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, 'SYS:/temp', + 'C:\system\temp', 'C:/temp', '/tmp', '/' ); diff --git a/locale.c b/locale.c index 7f336a6..94609a4 100644 --- a/locale.c +++ b/locale.c @@ -36,6 +36,7 @@ #include "reentr.h" +#if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE) /* * Standardize the locale name from a string returned by 'setlocale'. * @@ -79,6 +80,7 @@ S_stdize_locale(pTHX_ char *locs) return locs; } +#endif void Perl_set_numeric_radix(pTHX) @@ -173,7 +175,7 @@ void Perl_new_ctype(pTHX_ char *newctype) { #ifdef USE_LOCALE_CTYPE - + dVAR; int i; for (i = 0; i < 256; i++) { diff --git a/mg.c b/mg.c index af52790..39b8fd8 100644 --- a/mg.c +++ b/mg.c @@ -580,6 +580,7 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { + dVAR; register I32 paren; register char *s = NULL; register I32 i; @@ -962,6 +963,7 @@ Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) { + dVAR; register char *s; char *ptr; STRLEN len, klen; @@ -1047,7 +1049,7 @@ Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) { -#if defined(VMS) +#if defined(VMS) || defined(EPOC) || defined(SYMBIAN) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else if (PL_localizing) { @@ -1068,8 +1070,9 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) { + dVAR; #ifndef PERL_MICRO -#if defined(VMS) || defined(EPOC) +#if defined(VMS) || defined(EPOC) || defined(SYMBIAN) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else # if defined(PERL_IMPLICIT_SYS) || defined(WIN32) @@ -1104,16 +1107,6 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) return 0; } -#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS) -static int sig_handlers_initted = 0; -#endif -#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS -static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */ -#endif -#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS -static int sig_defaulting[SIG_SIZE]; -#endif - #ifndef PERL_MICRO #ifdef HAS_SIGPROCMASK static void @@ -1137,10 +1130,10 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) Sighandler_t sigstate; sigstate = rsignal_state(i); #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN; + if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL; + if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL; #endif /* cache state so we don't fetch it again */ if(sigstate == SIG_IGN) @@ -1159,18 +1152,19 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) /* XXX Some of this code was copied from Perl_magic_setsig. A little * refactoring might be in order. */ + dVAR; STRLEN n_a; register const char *s = MgPV(mg,n_a); (void)sv; if (*s == '_') { - SV** svp; + SV** svp = 0; if (strEQ(s,"__DIE__")) svp = &PL_diehook; else if (strEQ(s,"__WARN__")) svp = &PL_warnhook; else Perl_croak(aTHX_ "No such hook: %s", s); - if (*svp) { + if (svp && *svp) { SV *to_dec = *svp; *svp = 0; SvREFCNT_dec(to_dec); @@ -1195,10 +1189,10 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) #endif PERL_ASYNC_CHECK(); #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) - if (!sig_handlers_initted) Perl_csighandler_init(); + if (!PL_sig_handlers_initted) Perl_csighandler_init(); #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - sig_defaulting[i] = 1; + PL_sig_defaulting[i] = 1; (void)rsignal(i, PL_csighandlerp); #else (void)rsignal(i, SIG_DFL); @@ -1239,10 +1233,10 @@ Perl_csighandler(int sig) #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS (void) rsignal(sig, PL_csighandlerp); - if (sig_ignoring[sig]) return; + if (PL_sig_ignoring[sig]) return; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - if (sig_defaulting[sig]) + if (PL_sig_defaulting[sig]) #ifdef KILL_BY_SIGPRC exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG); #else @@ -1262,19 +1256,19 @@ void Perl_csighandler_init(void) { int sig; - if (sig_handlers_initted) return; + if (PL_sig_handlers_initted) return; for (sig = 1; sig < SIG_SIZE; sig++) { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS dTHX; - sig_defaulting[sig] = 1; + PL_sig_defaulting[sig] = 1; (void) rsignal(sig, PL_csighandlerp); #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - sig_ignoring[sig] = 0; + PL_sig_ignoring[sig] = 0; #endif } - sig_handlers_initted = 1; + PL_sig_handlers_initted = 1; } #endif @@ -1297,6 +1291,7 @@ Perl_despatch_signals(pTHX) int Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) { + dVAR; I32 i; SV** svp = 0; /* Need to be careful with SvREFCNT_dec(), because that can have side @@ -1343,13 +1338,13 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) #endif PERL_ASYNC_CHECK(); #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) - if (!sig_handlers_initted) Perl_csighandler_init(); + if (!PL_sig_handlers_initted) Perl_csighandler_init(); #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - sig_ignoring[i] = 0; + PL_sig_ignoring[i] = 0; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - sig_defaulting[i] = 0; + PL_sig_defaulting[i] = 0; #endif SvREFCNT_dec(PL_psig_name[i]); to_dec = PL_psig_ptr[i]; @@ -1375,7 +1370,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if (strEQ(s,"IGNORE")) { if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - sig_ignoring[i] = 1; + PL_sig_ignoring[i] = 1; (void)rsignal(i, PL_csighandlerp); #else (void)rsignal(i, SIG_IGN); @@ -1386,7 +1381,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if (i) #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS { - sig_defaulting[i] = 1; + PL_sig_defaulting[i] = 1; (void)rsignal(i, PL_csighandlerp); } #else @@ -1498,7 +1493,7 @@ S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) { - dSP; + dVAR; dSP; ENTER; SAVETMPS; @@ -1526,7 +1521,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) { - dSP; + dVAR; dSP; ENTER; PUSHSTACKi(PERLSI_MAGIC); magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); @@ -1545,7 +1540,7 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) { - dSP; + dVAR; dSP; U32 retval = 0; ENTER; @@ -1564,7 +1559,7 @@ Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) { - dSP; + dVAR; dSP; ENTER; PUSHSTACKi(PERLSI_MAGIC); @@ -1581,7 +1576,7 @@ Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) { - dSP; + dVAR; dSP; const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; ENTER; @@ -1612,7 +1607,7 @@ Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) SV * Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) { - dSP; + dVAR; dSP; SV *retval = &PL_sv_undef; SV *tied = SvTIED_obj((SV*)hv, mg); HV *pkg = SvSTASH((SV*)SvRV(tied)); @@ -2524,7 +2519,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) I32 Perl_whichsig(pTHX_ const char *sig) { - register const char **sigv; + register const char * const *sigv; for (sigv = PL_sig_name; *sigv; sigv++) if (strEQ(sig,*sigv)) @@ -2540,10 +2535,6 @@ Perl_whichsig(pTHX_ const char *sig) return -1; } -#if !defined(PERL_IMPLICIT_CONTEXT) -static SV* sig_sv; -#endif - Signal_t Perl_sighandler(int sig) { @@ -2603,7 +2594,7 @@ Perl_sighandler(int sig) sv = SvREFCNT_inc(PL_psig_name[sig]); flags |= 64; #if !defined(PERL_IMPLICIT_CONTEXT) - sig_sv = sv; + PL_sig_sv = sv; #endif } else { sv = sv_newmortal(); @@ -2705,6 +2696,7 @@ restore_magic(pTHX_ const void *p) static void unwind_handler_stack(pTHX_ const void *p) { + dVAR; const U32 flags = *(const U32*)p; if (flags & 1) @@ -2712,7 +2704,7 @@ unwind_handler_stack(pTHX_ const void *p) /* cxstack_ix-- Not needed, die already unwound it. */ #if !defined(PERL_IMPLICIT_CONTEXT) if (flags & 64) - SvREFCNT_dec(sig_sv); + SvREFCNT_dec(PL_sig_sv); #endif } diff --git a/miniperlmain.c b/miniperlmain.c index 252a48d..53ab947 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -44,27 +44,31 @@ static PerlInterpreter *my_perl; long _stksize = 64 * 1024; #endif +#if defined(PERL_GLOBAL_STRUCT_PRIVATE) +/* The static struct perl_vars* may seem counterproductive since the + * whole idea PERL_GLOBAL_STRUCT_PRIVATE was to avoid statics, but note + * that this static is not in the shared perl library, the globals PL_Vars + * and PL_VarsPtr will stay away. */ +static struct perl_vars* my_plvarsp; +struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; } +#endif + int main(int argc, char **argv, char **env) { + dVAR; int exitstatus; +#ifdef PERL_GLOBAL_STRUCT + struct perl_vars *plvarsp = init_global_struct(); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + my_vars = my_plvarsp = plvarsp; +# endif +#endif /* PERL_GLOBAL_STRUCT */ (void)env; #ifndef PERL_USE_SAFE_PUTENV PL_use_safe_putenv = 0; #endif /* PERL_USE_SAFE_PUTENV */ -#ifdef PERL_GLOBAL_STRUCT -#define PERLVAR(var,type) /**/ -#define PERLVARA(var,type) /**/ -#define PERLVARI(var,type,init) PL_Vars.var = init; -#define PERLVARIC(var,type,init) PL_Vars.var = init; -#include "perlvars.h" -#undef PERLVAR -#undef PERLVARA -#undef PERLVARI -#undef PERLVARIC -#endif - /* if user wants control of gprof profiling off by default */ /* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */ PERL_GPROF_MONCONTROL(0); @@ -102,6 +106,10 @@ main(int argc, char **argv, char **env) perl_free(my_perl); +#ifdef PERL_GLOBAL_STRUCT + free_global_struct(plvarsp); +#endif /* PERL_GLOBAL_STRUCT */ + PERL_SYS_TERM(); exit(exitstatus); diff --git a/numeric.c b/numeric.c index 38f00fc..297dbdd 100644 --- a/numeric.c +++ b/numeric.c @@ -261,6 +261,7 @@ number may use '_' characters to separate digits. UV Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { + dVAR; const char *s = start; STRLEN len = *len_p; UV value = 0; diff --git a/op.c b/op.c index 8264232..ef8dfca 100644 --- a/op.c +++ b/op.c @@ -270,6 +270,7 @@ Perl_allocmy(pTHX_ char *name) void Perl_op_free(pTHX_ OP *o) { + dVAR; OPCODE type; PADOFFSET refcnt; @@ -323,6 +324,7 @@ void Perl_op_clear(pTHX_ OP *o) { + dVAR; switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ case OP_ENTEREVAL: /* Was holding hints. */ @@ -471,6 +473,7 @@ S_cop_free(pTHX_ COP* cop) void Perl_op_null(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_NULL) return; op_clear(o); @@ -482,12 +485,14 @@ Perl_op_null(pTHX_ OP *o) void Perl_op_refcnt_lock(pTHX) { + dVAR; OP_REFCNT_LOCK; } void Perl_op_refcnt_unlock(pTHX) { + dVAR; OP_REFCNT_UNLOCK; } @@ -549,6 +554,7 @@ S_scalarboolean(pTHX_ OP *o) OP * Perl_scalar(pTHX_ OP *o) { + dVAR; OP *kid; /* assumes no premature commitment */ @@ -619,6 +625,7 @@ Perl_scalar(pTHX_ OP *o) OP * Perl_scalarvoid(pTHX_ OP *o) { + dVAR; OP *kid; const char* useless = 0; SV* sv; @@ -858,6 +865,7 @@ Perl_listkids(pTHX_ OP *o) OP * Perl_list(pTHX_ OP *o) { + dVAR; OP *kid; /* assumes no premature commitment */ @@ -981,6 +989,7 @@ S_modkids(pTHX_ OP *o, I32 type) OP * Perl_mod(pTHX_ OP *o, I32 type) { + dVAR; OP *kid; /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ int localize = -1; @@ -1403,6 +1412,7 @@ Perl_refkids(pTHX_ OP *o, I32 type) OP * Perl_ref(pTHX_ OP *o, I32 type) { + dVAR; OP *kid; if (!o || PL_error_count) @@ -1515,6 +1525,7 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) { + dVAR; SV *stashsv; /* fake up C */ @@ -1828,6 +1839,7 @@ Perl_invert(pTHX_ OP *o) OP * Perl_scope(pTHX_ OP *o) { + dVAR; if (o) { if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); @@ -2013,6 +2025,7 @@ Perl_jmaybe(pTHX_ OP *o) OP * Perl_fold_constants(pTHX_ register OP *o) { + dVAR; register OP *curop; I32 type = o->op_type; SV *sv; @@ -2092,6 +2105,7 @@ Perl_fold_constants(pTHX_ register OP *o) OP * Perl_gen_constant_list(pTHX_ register OP *o) { + dVAR; register OP *curop; const I32 oldtmps_floor = PL_tmps_floor; @@ -2123,6 +2137,7 @@ Perl_gen_constant_list(pTHX_ register OP *o) OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { + dVAR; if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, Nullop); else @@ -2244,6 +2259,7 @@ Perl_force_list(pTHX_ OP *o) OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { + dVAR; LISTOP *listop; NewOp(1101, listop, 1, LISTOP); @@ -2278,6 +2294,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) OP * Perl_newOP(pTHX_ I32 type, I32 flags) { + dVAR; OP *o; NewOp(1101, o, 1, OP); o->op_type = (OPCODE)type; @@ -2296,6 +2313,7 @@ Perl_newOP(pTHX_ I32 type, I32 flags) OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) { + dVAR; UNOP *unop; if (!first) @@ -2319,6 +2337,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) OP * Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { + dVAR; BINOP *binop; NewOp(1101, binop, 1, BINOP); @@ -2671,6 +2690,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { + dVAR; PMOP *pmop; NewOp(1101, pmop, 1, PMOP); @@ -2727,6 +2747,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) { + dVAR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; @@ -2896,6 +2917,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) { + dVAR; SVOP *svop; NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)type; @@ -2913,6 +2935,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { + dVAR; PADOP *padop; NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; @@ -2934,6 +2957,7 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { + dVAR; #ifdef USE_ITHREADS if (gv) GvIN_PAD_on(gv); @@ -2946,6 +2970,7 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { + dVAR; PVOP *pvop; NewOp(1101, pvop, 1, PVOP); pvop->op_type = (OPCODE)type; @@ -3406,6 +3431,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { + dVAR; const U32 seq = intro_my(); register COP *cop; @@ -3470,12 +3496,14 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) { + dVAR; return new_logop(type, flags, &first, &other); } STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { + dVAR; LOGOP *logop; OP *o; OP *first = *firstp; @@ -3610,6 +3638,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { + dVAR; LOGOP *logop; OP *start; OP *o; @@ -3665,6 +3694,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { + dVAR; LOGOP *range; OP *flip; OP *flop; @@ -3771,6 +3801,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont) { + dVAR; OP *redo; OP *next = 0; OP *listop; @@ -3865,6 +3896,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * OP * Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) { + dVAR; LOOP *loop; OP *wop; PADOFFSET padoff = 0; @@ -4004,6 +4036,7 @@ children can still follow the full lexical scope chain. void Perl_cv_undef(pTHX_ CV *cv) { + dVAR; #ifdef USE_ITHREADS if (CvFILE(cv) && !CvXSUB(cv)) { /* for XSUBs CvFILE point directly to static memory; __FILE__ */ @@ -4194,6 +4227,7 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { + dVAR; STRLEN n_a; const char *name; const char *aname; @@ -4552,6 +4586,7 @@ eligible for inlining at compile-time. CV * Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) { + dVAR; CV* cv; ENTER; @@ -4768,6 +4803,7 @@ Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) OP * Perl_oopsAV(pTHX_ OP *o) { + dVAR; switch (o->op_type) { case OP_PADSV: o->op_type = OP_PADAV; @@ -4791,6 +4827,7 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { + dVAR; switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -4816,6 +4853,7 @@ Perl_oopsHV(pTHX_ OP *o) OP * Perl_newAVREF(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_PADANY) { o->op_type = OP_PADAV; o->op_ppaddr = PL_ppaddr[OP_PADAV]; @@ -4840,6 +4878,7 @@ Perl_newGVREF(pTHX_ I32 type, OP *o) OP * Perl_newHVREF(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_PADANY) { o->op_type = OP_PADHV; o->op_ppaddr = PL_ppaddr[OP_PADHV]; @@ -4875,6 +4914,7 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o) OP * Perl_newSVREF(pTHX_ OP *o) { + dVAR; if (o->op_type == OP_PADANY) { o->op_type = OP_PADSV; o->op_ppaddr = PL_ppaddr[OP_PADSV]; @@ -4944,6 +4984,7 @@ Perl_ck_concat(pTHX_ OP *o) OP * Perl_ck_spair(pTHX_ OP *o) { + dVAR; if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; @@ -5021,6 +5062,7 @@ Perl_ck_eof(pTHX_ OP *o) OP * Perl_ck_eval(pTHX_ OP *o) { + dVAR; PL_hints |= HINT_BLOCK_SCOPE; if (o->op_flags & OPf_KIDS) { SVOP *kid = (SVOP*)cUNOPo->op_first; @@ -5129,6 +5171,7 @@ Perl_ck_gvconst(pTHX_ register OP *o) OP * Perl_ck_rvconst(pTHX_ register OP *o) { + dVAR; SVOP *kid = (SVOP*)cUNOPo->op_first; o->op_private |= (PL_hints & HINT_STRICT_REFS); @@ -5227,6 +5270,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) OP * Perl_ck_ftst(pTHX_ OP *o) { + dVAR; const I32 type = o->op_type; if (o->op_flags & OPf_REF) { @@ -5512,6 +5556,7 @@ Perl_ck_fun(pTHX_ OP *o) OP * Perl_ck_glob(pTHX_ OP *o) { + dVAR; GV *gv; o = ck_fun(o); @@ -5566,6 +5611,7 @@ Perl_ck_glob(pTHX_ OP *o) OP * Perl_ck_grep(pTHX_ OP *o) { + dVAR; LOGOP *gwop; OP *kid; const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; @@ -5943,6 +5989,7 @@ Perl_ck_retarget(pTHX_ OP *o) OP * Perl_ck_select(pTHX_ OP *o) { + dVAR; OP* kid; if (o->op_flags & OPf_KIDS) { kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ @@ -6111,6 +6158,7 @@ S_simplify_sort(pTHX_ OP *o) OP * Perl_ck_split(pTHX_ OP *o) { + dVAR; register OP *kid; if (o->op_flags & OPf_STACKED) @@ -6474,6 +6522,7 @@ Perl_ck_substr(pTHX_ OP *o) void Perl_peep(pTHX_ register OP *o) { + dVAR; register OP* oldop = 0; if (!o || o->op_opt) @@ -7040,13 +7089,13 @@ Perl_custom_op_name(pTHX_ const OP* o) HE* he; if (!PL_custom_op_names) /* This probably shouldn't happen */ - return PL_op_name[OP_CUSTOM]; + return (char *)PL_op_name[OP_CUSTOM]; keysv = sv_2mortal(newSViv(index)); he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0); if (!he) - return PL_op_name[OP_CUSTOM]; /* Don't know who you are */ + return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */ return SvPV_nolen(HeVAL(he)); } @@ -7059,13 +7108,13 @@ Perl_custom_op_desc(pTHX_ const OP* o) HE* he; if (!PL_custom_op_descs) - return PL_op_desc[OP_CUSTOM]; + return (char *)PL_op_desc[OP_CUSTOM]; keysv = sv_2mortal(newSViv(index)); he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0); if (!he) - return PL_op_desc[OP_CUSTOM]; + return (char *)PL_op_desc[OP_CUSTOM]; return SvPV_nolen(HeVAL(he)); } diff --git a/opcode.h b/opcode.h index 356145f..8e52cf6 100644 --- a/opcode.h +++ b/opcode.h @@ -12,24 +12,24 @@ * will be lost! */ +#ifndef PERL_GLOBAL_STRUCT_INIT + #define Perl_pp_i_preinc Perl_pp_preinc #define Perl_pp_i_predec Perl_pp_predec #define Perl_pp_i_postinc Perl_pp_postinc #define Perl_pp_i_postdec Perl_pp_postdec - START_EXTERN_C - #define OP_NAME(o) ((o)->op_type == OP_CUSTOM ? custom_op_name(o) : \ PL_op_name[(o)->op_type]) #define OP_DESC(o) ((o)->op_type == OP_CUSTOM ? custom_op_desc(o) : \ PL_op_desc[(o)->op_type]) #ifndef DOINIT -EXT char *PL_op_name[]; +EXTCONST char* const PL_op_name[]; #else -EXT char *PL_op_name[] = { +EXTCONST char* const PL_op_name[] = { "null", "stub", "scalar", @@ -388,9 +388,9 @@ EXT char *PL_op_name[] = { #endif #ifndef DOINIT -EXT char *PL_op_desc[]; +EXTCONST char* const PL_op_desc[]; #else -EXT char *PL_op_desc[] = { +EXTCONST char* const PL_op_desc[] = { "null operation", "stub", "scalar", @@ -750,13 +750,20 @@ EXT char *PL_op_desc[] = { END_EXTERN_C +#endif /* !PERL_GLOBAL_STRUCT_INIT */ + START_EXTERN_C -#ifndef DOINIT -EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX); +#ifdef PERL_GLOBAL_STRUCT_INIT +static const Perl_ppaddr_t Gppaddr[] #else -EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX) = { +# ifndef PERL_GLOBAL_STRUCT +EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ +# endif +#endif /* PERL_GLOBAL_STRUCT */ +#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT) += { MEMBER_TO_FPTR(Perl_pp_null), MEMBER_TO_FPTR(Perl_pp_stub), MEMBER_TO_FPTR(Perl_pp_scalar), @@ -1110,13 +1117,19 @@ EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX) = { MEMBER_TO_FPTR(Perl_pp_method_named), MEMBER_TO_FPTR(Perl_pp_dor), MEMBER_TO_FPTR(Perl_pp_dorassign), -}; +} #endif +; -#ifndef DOINIT -EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op); +#ifdef PERL_GLOBAL_STRUCT_INIT +static const Perl_check_t Gcheck[] #else -EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = { +# ifndef PERL_GLOBAL_STRUCT +EXT Perl_check_t PL_check[] /* or perlvars.h */ +# endif +#endif +#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT) += { MEMBER_TO_FPTR(Perl_ck_null), /* null */ MEMBER_TO_FPTR(Perl_ck_null), /* stub */ MEMBER_TO_FPTR(Perl_ck_fun), /* scalar */ @@ -1471,13 +1484,16 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = { MEMBER_TO_FPTR(Perl_ck_null), /* dor */ MEMBER_TO_FPTR(Perl_ck_null), /* dorassign */ MEMBER_TO_FPTR(Perl_ck_null), /* custom */ -}; +} #endif +; + +#ifndef PERL_GLOBAL_STRUCT_INIT #ifndef DOINIT -EXT U32 PL_opargs[]; +EXT const U32 PL_opargs[]; #else -EXT U32 PL_opargs[] = { +EXT const U32 PL_opargs[] = { 0x00000000, /* null */ 0x00000000, /* stub */ 0x00003604, /* scalar */ @@ -1836,3 +1852,5 @@ EXT U32 PL_opargs[] = { #endif END_EXTERN_C + +#endif /* !PERL_GLOBAL_STRUCT_INIT */ diff --git a/opcode.pl b/opcode.pl index d9c81b3..ac9499d 100755 --- a/opcode.pl +++ b/opcode.pl @@ -51,6 +51,8 @@ print <<"END"; * will be lost! */ +#ifndef PERL_GLOBAL_STRUCT_INIT + #define Perl_pp_i_preinc Perl_pp_preinc #define Perl_pp_i_predec Perl_pp_predec #define Perl_pp_i_postinc Perl_pp_postinc @@ -88,19 +90,17 @@ print ON "#define OP_phoney_OUTPUT_ONLY -2\n\n"; # Emit op names and descriptions. print <op_type == OP_CUSTOM ? custom_op_name(o) : \\ PL_op_name[(o)->op_type]) #define OP_DESC(o) ((o)->op_type == OP_CUSTOM ? custom_op_desc(o) : \\ PL_op_desc[(o)->op_type]) #ifndef DOINIT -EXT char *PL_op_name[]; +EXTCONST char* const PL_op_name[]; #else -EXT char *PL_op_name[] = { +EXTCONST char* const PL_op_name[] = { END for (@ops) { @@ -115,9 +115,9 @@ END print <. void perl_construct(pTHXx) { + dVAR; #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -303,7 +305,9 @@ perl_construct(pTHXx) /* Use sysconf(_SC_CLK_TCK) if available, if not * available or if the sysconf() fails, use the HZ. - * BeOS has those, but returns the wrong value. */ + * BeOS has those, but returns the wrong value. + * The HZ if not originally defined has been by now + * been defined as CLK_TCK, if available. */ #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__) PL_clocktick = sysconf(_SC_CLK_TCK); if (PL_clocktick <= 0) @@ -319,6 +323,51 @@ perl_construct(pTHXx) (int)PERL_SUBVERSION ), 0 ); +#ifdef HAS_MMAP + if (!PL_mmap_page_size) { +#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) + { + SETERRNO(0, SS_NORMAL); +# ifdef _SC_PAGESIZE + PL_mmap_page_size = sysconf(_SC_PAGESIZE); +# else + PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); +# endif + if ((long) PL_mmap_page_size < 0) { + if (errno) { + SV *error = ERRSV; + char *msg; + STRLEN n_a; + (void) SvUPGRADE(error, SVt_PV); + msg = SvPVx(error, n_a); + Perl_croak(aTHX_ "panic: sysconf: %s", msg); + } + else + Perl_croak(aTHX_ "panic: sysconf: pagesize unknown"); + } + } +#else +# ifdef HAS_GETPAGESIZE + PL_mmap_page_size = getpagesize(); +# else +# if defined(I_SYS_PARAM) && defined(PAGESIZE) + PL_mmap_page_size = PAGESIZE; /* compiletime, bad */ +# endif +# endif +#endif + if (PL_mmap_page_size <= 0) + Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, + (IV) PL_mmap_page_size); + } +#endif /* HAS_MMAP */ + +#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE) + PL_timesbase.tms_utime = 0; + PL_timesbase.tms_stime = 0; + PL_timesbase.tms_cutime = 0; + PL_timesbase.tms_cstime = 0; +#endif + ENTER; } @@ -348,6 +397,7 @@ Shuts down a Perl interpreter. See L. int perl_destruct(pTHXx) { + dVAR; volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */ HV *hv; @@ -366,8 +416,7 @@ perl_destruct(pTHXx) } #endif - - if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) { + if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) { dJMPENV; int x = 0; @@ -967,6 +1016,7 @@ perl_free(pTHXx) static void __attribute__((destructor)) perl_fini() { + dVAR; if (PL_curinterp) FREE_THREAD_KEY; } @@ -1045,6 +1095,7 @@ Tells a Perl interpreter to parse a Perl script. See L. int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { + dVAR; I32 oldscope; int ret; dJMPENV; @@ -1229,6 +1280,7 @@ setuid perl scripts securely.\n"); STATIC void * S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { + dVAR; int argc = PL_origargc; char **argv = PL_origargv; const char *scriptname = NULL; @@ -1663,10 +1715,13 @@ print \" \\@INC:\\n @INC\\n\";"); if (!PL_do_undump) init_postdump_symbols(argc,argv,env); - /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}. - * PL_utf8locale is conditionally turned on by + /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE}, + * or explicitly in some platforms. * locale.c:Perl_init_i18nl10n() if the environment * look like the user wants to use UTF-8. */ +#if defined(SYMBIAN) + PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */ +#endif if (PL_unicode) { /* Requires init_predump_symbols(). */ if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { @@ -1869,7 +1924,6 @@ S_run_body(pTHX_ I32 oldscope) PL_op = PL_main_start; CALLRUNOPS(aTHX); } - my_exit(0); /* NOTREACHED */ } @@ -2059,7 +2113,7 @@ I32 Perl_call_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { - dSP; + dVAR; dSP; LOGOP myop; /* fake syntax tree node */ UNOP method_op; I32 oldmark; @@ -2382,7 +2436,7 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ /* This message really ought to be max 23 lines. * Removed -h because the user already knows that option. Others? */ - static const char *usage_msg[] = { + static const char * const usage_msg[] = { "-0[octal] specify record separator (\\0, if no argument)", "-a autosplit mode with -n or -p (splits $_ into @F)", "-C[number/list] enables the listed Unicode features", @@ -2414,7 +2468,7 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ "\n", NULL }; - const char **p = usage_msg; + const char * const *p = usage_msg; PerlIO_printf(PerlIO_stdout(), "\nUsage: %s [switches] [--] [programfile] [arguments]", @@ -2430,7 +2484,7 @@ NULL int Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) { - static const char *usage_msgd[] = { + static const char * const usage_msgd[] = { " Debugging flag values: (see also -d)", " p Tokenizing and parsing (with v, displays parse stack)", " s Stack snapshots (with v, displays all stacks)", @@ -2493,6 +2547,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) char * Perl_moreswitches(pTHX_ char *s) { + dVAR; STRLEN numlen; UV rschar; @@ -2856,6 +2911,10 @@ Perl_moreswitches(pTHX_ char *s) PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n"); wce_hitreturn(); #endif +#ifdef SYMBIAN + PerlIO_printf(PerlIO_stdout(), + "Symbian port by Nokia, 2004-2005\n"); +#endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; #endif @@ -2956,7 +3015,7 @@ S_init_interp(pTHX) # if defined(PERL_IMPLICIT_CONTEXT) # if defined(USE_5005THREADS) # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; -# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; +# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; # else /* !USE_5005THREADS */ # define PERLVARI(var,type,init) aTHX->var = init; # define PERLVARIC(var,type,init) aTHX->var = init; @@ -3032,6 +3091,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) const char *cpp_discard_flag; const char *perl; #endif + dVAR; PL_fdscript = -1; PL_suidscript = -1; @@ -3328,6 +3388,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) STATIC void S_validate_suid(pTHX_ const char *validarg, const char *scriptname) { + dVAR; #ifdef IAMSUID /* int which; */ #endif /* IAMSUID */ @@ -4071,8 +4132,7 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) STATIC void S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { - char *s; - SV *sv; + dVAR; GV* tmpgv; PL_toptarget = NEWSV(0,0); @@ -4120,6 +4180,8 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register } if (env) { char** origenv = environ; + char *s; + SV *sv; for (; *env; env++) { if (!(s = strchr(*env,'=')) || s == *env) continue; @@ -4276,7 +4338,7 @@ S_init_perllib(pTHX) #endif /* MACOS_TRADITIONAL */ } -#if defined(DOSISH) || defined(EPOC) +#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN) # define PERLLIB_SEP ';' #else # if defined(VMS) @@ -4609,6 +4671,7 @@ S_init_main_thread(pTHX) void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { + dVAR; SV *atsv; const line_t oldline = CopLINE(PL_curcop); CV *cv; @@ -4753,6 +4816,7 @@ Perl_my_failure_exit(pTHX) STATIC void S_my_exit_jump(pTHX) { + dVAR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; diff --git a/perl.h b/perl.h index c867ab2..e0b1a94 100644 --- a/perl.h +++ b/perl.h @@ -65,13 +65,45 @@ # endif #endif +#ifdef PERL_GLOBAL_STRUCT_PRIVATE +# ifndef PERL_GLOBAL_STRUCT +# define PERL_GLOBAL_STRUCT +# endif +#endif +#ifdef PERL_GLOBAL_STRUCT +# ifndef MULTIPLICITY +# define MULTIPLICITY +# endif +#endif + /* undef WIN32 when building on Cygwin (for libwin32) - gph */ #ifdef __CYGWIN__ # undef WIN32 # undef _WIN32 #endif -/* Use the reentrant APIs like localtime_r and getpwent_r */ +#if defined(__SYMBIAN32__) || (defined(__VC32__) && defined(WINS)) +# ifndef SYMBIAN +# define SYMBIAN +# endif +#endif + +#ifdef SYMBIAN +# include "symbian/symbian_proto.h" +#endif + +/* Any stack-challenged places. The limit varies (and often + * is configurable), but using more than a kilobyte of stack + * is usually dubious in these systems. */ +#if defined(EPOC) || defined(SYMBIAN) +/* EPOC/Symbian: need to work around the SDK features. * + * On WINS: MS VC5 generates calls to _chkstk, * + * if a "large" stack frame is allocated. * + * gcc on MARM does not generate calls like these. */ +# define USE_HEAP_INSTEAD_OF_STACK +#endif + +#/* Use the reentrant APIs like localtime_r and getpwent_r */ /* Win32 has naturally threadsafe libraries, no need to use any _r variants. */ #if defined(USE_ITHREADS) && !defined(USE_REENTRANT_API) && !defined(NETWARE) && !defined(WIN32) && !defined(PERL_DARWIN) # define USE_REENTRANT_API @@ -90,14 +122,44 @@ # endif #endif +#ifdef PERL_GLOBAL_STRUCT +# ifndef PERL_GET_VARS +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + extern struct perl_vars* Perl_GetVarsPrivate(); +# define PERL_GET_VARS() Perl_GetVarsPrivate() /* see miniperlmain.c */ +# ifndef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_CONST /* Can't have these lying around. */ +# endif +# else +# define PERL_GET_VARS() PL_VarsPtr +# endif +# endif +#endif + +#define pVAR register struct perl_vars* my_vars PERL_UNUSED_DECL + +#ifdef PERL_GLOBAL_STRUCT +# define dVAR pVAR = (struct perl_vars*)PERL_GET_VARS() +#else +# define dVAR dNOOP +#endif + #ifdef PERL_IMPLICIT_CONTEXT # ifndef MULTIPLICITY # define MULTIPLICITY # endif # define pTHX register PerlInterpreter *my_perl PERL_UNUSED_DECL # define aTHX my_perl -# define dTHXa(a) pTHX = (PerlInterpreter*)a -# define dTHX pTHX = PERL_GET_THX +# ifdef PERL_GLOBAL_STRUCT +# define dTHXa(a) dVAR; pTHX = (PerlInterpreter*)a +# else +# define dTHXa(a) pTHX = (PerlInterpreter*)a +# endif +# ifdef PERL_GLOBAL_STRUCT +# define dTHX dVAR; pTHX = PERL_GET_THX +# else +# define dTHX pTHX = PERL_GET_THX +# endif # define pTHX_ pTHX, # define aTHX_ aTHX, # define pTHX_1 2 @@ -123,6 +185,12 @@ #define CALLREG_INTUIT_STRING CALL_FPTR(PL_regint_string) #define CALLREGFREE CALL_FPTR(PL_regfree) +#if defined(SYMBIAN) && defined(__GNUC__) +# undef __attribute__ +# undef __attribute__(_arg_) +# define HASATTRIBUTE +#endif + #ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL @@ -132,6 +200,12 @@ #else # define PERL_UNUSED_DECL #endif + +#if defined(SYMBIAN) && defined(__GNUC__) +# undef __attribute__ +# undef __attribute__(_arg_) +# define HASATTRIBUTE +#endif /* gcc -Wall: * for silencing unused variables that are actually used most of the time, @@ -155,6 +229,10 @@ # define pTHX_4 4 #endif +#ifndef dVAR +# define dVAR dNOOP +#endif + /* these are only defined for compatibility; should not be used internally */ #if !defined(pTHXo) && !defined(PERL_CORE) # define pTHXo pTHX @@ -177,9 +255,17 @@ * PerlIO_foo() expands to PL_StdIO->pFOO(PL_StdIO, ...). * dTHXs is therefore needed for all functions using PerlIO_foo(). */ #ifdef PERL_IMPLICIT_SYS -# define dTHXs dTHX +# ifdef PERL_GLOBAL_STRUCT_PRIVATE +# define dTHXs dVAR; dTHX +# else +# define dTHXs dTHX +# endif #else -# define dTHXs dNOOP +# ifdef PERL_GLOBAL_STRUCT_PRIVATE +# define dTHXs dVAR +# else +# define dTHXs dNOOP +# endif #endif #undef START_EXTERN_C @@ -195,6 +281,18 @@ # define EXTERN_C extern #endif +/* Some platforms require marking function declarations + * for them to be exportable. Used in perlio.h, proto.h + * is handled either by the makedef.pl or by defining the + * PERL_CALLCONV to be something special. See also the + * definition of XS() in XSUB.h. */ +#ifndef PERL_EXPORT_C +# define PERL_EXPORT_C extern +#endif +#ifndef PERL_XS_EXPORT_C +# define PERL_XS_EXPORT_C +#endif + #ifdef OP_IN_REGISTER # ifdef __GNUC__ # define stringify_immed(s) #s @@ -273,7 +371,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); #define DOSISH 1 #endif -#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined( EPOC) || defined(NETWARE) +#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined( EPOC) || defined(NETWARE) || defined(SYMBIAN) # define STANDARD_C 1 #endif @@ -435,6 +533,10 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # include #endif +#ifdef SYMBIAN +# undef _SC_ARG_MAX /* Symbian has _SC_ARG_MAX but no sysconf() */ +#endif + #if defined(HAS_SYSCALL) && !defined(HAS_SYSCALL_PROTO) && !defined(PERL_MICRO) int syscall(int, ...); #endif @@ -698,10 +800,12 @@ int usleep(unsigned int); # define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m)) #endif -#if defined(I_STRING) || defined(__cplusplus) -# include -#else -# include +#ifndef SYMBIAN +# if defined(I_STRING) || defined(__cplusplus) +# include +# else +# include +# endif #endif /* This comes after so we don't try to change the standard @@ -749,7 +853,7 @@ int usleep(unsigned int); # define MALLOC_CHECK_TAINT(argc,argv,env) #endif /* MYMALLOC */ -#define TOO_LATE_FOR_(ch,s) Perl_croak(aTHX_ "\"-%c\" is on the #! line, it must also be used on the command line%s", (char)(ch), s) +#define TOO_LATE_FOR_(ch,what) Perl_croak(aTHX_ "\"-%c\" is on the #! line, it must also be used on the command line%s", (char)(ch), what) #define TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, "") #define MALLOC_TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, " with $ENV{PERL_MALLOC_OPT}") #define MALLOC_CHECK_TAINT2(argc,argv) MALLOC_CHECK_TAINT(argc,argv,NULL) @@ -2157,6 +2261,12 @@ typedef struct clone_params CLONE_PARAMS; # define ISHISH "epoc" #endif +#ifdef SYMBIAN +# include "symbian/symbianish.h" +# include "embed.h" +# define ISHISH "symbian" +#endif + #if defined(MACOS_TRADITIONAL) # include "macos/macish.h" # ifndef NO_ENVIRON_ARRAY @@ -2703,7 +2813,7 @@ long vtohl(long n); #endif #ifndef __cplusplus -#ifndef UNDER_CE +#if !(defined(UNDER_CE) || defined(SYMBIAN)) Uid_t getuid (void); Uid_t geteuid (void); Gid_t getgid (void); @@ -3268,18 +3378,18 @@ EXTCONST char PL_uuemap[65] #ifdef DOINIT -EXT const char *PL_sig_name[] = { SIG_NAME }; -EXT int PL_sig_num[] = { SIG_NUM }; +EXTCONST char* const PL_sig_name[] = { SIG_NAME }; +EXTCONST int PL_sig_num[] = { SIG_NUM }; #else -EXT const char *PL_sig_name[]; -EXT int PL_sig_num[]; +EXTCONST char* const PL_sig_name[]; +EXTCONST int PL_sig_num[]; #endif /* fast conversion and case folding tables */ #ifdef DOINIT #ifdef EBCDIC -EXT unsigned char PL_fold[] = { /* fast EBCDIC case folding table */ +EXTCONST unsigned char PL_fold[] = { /* fast EBCDIC case folding table */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, @@ -3353,8 +3463,9 @@ EXTCONST unsigned char PL_fold[] = { EXTCONST unsigned char PL_fold[]; #endif +#ifndef PERL_GLOBAL_STRUCT /* or perlvars.h */ #ifdef DOINIT -EXT unsigned char PL_fold_locale[] = { +EXT unsigned char PL_fold_locale[] = { /* Unfortunately not EXTCONST. */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, @@ -3389,12 +3500,13 @@ EXT unsigned char PL_fold_locale[] = { 248, 249, 250, 251, 252, 253, 254, 255 }; #else -EXT unsigned char PL_fold_locale[]; +EXT unsigned char PL_fold_locale[]; /* Unfortunately not EXTCONST. */ #endif +#endif /* !PERL_GLOBAL_STRUCT */ #ifdef DOINIT #ifdef EBCDIC -EXT unsigned char PL_freq[] = {/* EBCDIC frequencies for mixed English/C */ +EXTCONST unsigned char PL_freq[] = {/* EBCDIC frequencies for mixed English/C */ 1, 2, 84, 151, 154, 155, 156, 157, 165, 246, 250, 3, 158, 7, 18, 29, 40, 51, 62, 73, 85, 96, 107, 118, @@ -3470,7 +3582,7 @@ EXTCONST unsigned char PL_freq[]; #ifdef DEBUGGING #ifdef DOINIT -EXTCONST char* PL_block_type[] = { +EXTCONST char* const PL_block_type[] = { "NULL", "SUB", "EVAL", @@ -3641,6 +3753,10 @@ typedef void (*XSUBADDR_t) (pTHX_ CV *); #define PERLVARA(var,n,type) type var[n]; #define PERLVARI(var,type,init) type var; #define PERLVARIC(var,type,init) type var; +#define PERLVARISC(var,init) const char var[sizeof(init)]; + +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); /* Interpreter exitlist entry */ typedef struct exitlistentry { @@ -3654,8 +3770,12 @@ struct perl_vars { }; # ifdef PERL_CORE +# ifndef PERL_GLOBAL_STRUCT_PRIVATE EXT struct perl_vars PL_Vars; EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars); +# undef PERL_GET_VARS +# define PERL_GET_VARS() PL_VarsPtr +# endif /* !PERL_GLOBAL_STRUCT_PRIVATE */ # else /* PERL_CORE */ # if !defined(__GNUC__) || !defined(WIN32) EXT @@ -3696,6 +3816,7 @@ typedef void *Thread; #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC /* Types used by pack/unpack */ typedef enum { @@ -3760,6 +3881,7 @@ typedef struct tempsym { #define PERLVARA(var,n,type) EXT type PL_##var[n]; #define PERLVARI(var,type,init) EXT type PL_##var INIT(init); #define PERLVARIC(var,type,init) EXTCONST type PL_##var INIT(init); +#define PERLVARISC(var,init) EXTCONST char PL_##var[sizeof(init)] INIT(init); #if !defined(MULTIPLICITY) START_EXTERN_C @@ -3789,9 +3911,9 @@ END_EXTERN_C START_EXTERN_C #ifdef DOINIT -# define MGVTBL_SET(var,a,b,c,d,e,f,g) EXT MGVTBL var = {a,b,c,d,e,f,g} +# define MGVTBL_SET(var,a,b,c,d,e,f,g) EXTCONST MGVTBL var = {a,b,c,d,e,f,g} #else -# define MGVTBL_SET(var,a,b,c,d,e,f,g) EXT MGVTBL var +# define MGVTBL_SET(var,a,b,c,d,e,f,g) EXTCONST MGVTBL var #endif MGVTBL_SET( @@ -4187,7 +4309,7 @@ enum { #define AMG_id2name(id) (PL_AMG_names[id]+1) #ifdef DOINIT -EXTCONST char * PL_AMG_names[NofAMmeth] = { +EXTCONST char * const PL_AMG_names[NofAMmeth] = { /* Names kept in the symbol table. fallback => "()", the rest has "(" prepended. The only other place in perl which knows about this convention is AMG_id2name (used for debugging output and diff --git a/perlapi.c b/perlapi.c index e0bf9fb..b1ed782 100644 --- a/perlapi.c +++ b/perlapi.c @@ -34,14 +34,17 @@ START_EXTERN_C #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ - { return &(aTHX->v); } + { dVAR; return &(aTHX->v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ - { return &(aTHX->v); } + { dVAR; return &(aTHX->v); } #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) +#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ + { dVAR; return &(aTHX->v); } #include "thrdvar.h" #include "intrpvar.h" @@ -49,18 +52,42 @@ START_EXTERN_C #undef PERLVAR #undef PERLVARA #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \ - { return &(PL_##v); } + { dVAR; return &(PL_##v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \ - { return &(PL_##v); } + { dVAR; return &(PL_##v); } #undef PERLVARIC -#define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \ +#undef PERLVARISC +#define PERLVARIC(v,t,i) \ + const t* Perl_##v##_ptr(pTHX) \ { return (const t *)&(PL_##v); } +#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \ + { dVAR; return &(PL_##v); } #include "perlvars.h" #undef PERLVAR #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC + +#ifndef PERL_GLOBAL_STRUCT +/* A few evil special cases. Could probably macrofy this. */ +#undef PL_ppaddr +#undef PL_check +#undef PL_fold_locale +Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) { + static const Perl_ppaddr_t* ppaddr_ptr = PL_ppaddr; + return (Perl_ppaddr_t**)&ppaddr_ptr; +} +Perl_check_t** Perl_Gcheck_ptr(pTHX) { + static const Perl_check_t* check_ptr = PL_check; + return (Perl_check_t**)&check_ptr; +} +unsigned char** Perl_Gfold_locale_ptr(pTHX) { + static const unsigned char* fold_locale_ptr = PL_fold_locale; + return (unsigned char**)&fold_locale_ptr; +} +#endif END_EXTERN_C diff --git a/perlapi.h b/perlapi.h index 28edb59..c9ccd69 100644 --- a/perlapi.h +++ b/perlapi.h @@ -27,11 +27,14 @@ START_EXTERN_C #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX); #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \ EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v, const t) +#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \ + EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX); #include "thrdvar.h" #include "intrpvar.h" @@ -41,6 +44,16 @@ START_EXTERN_C #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC + +#ifndef PERL_GLOBAL_STRUCT +EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX); +EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX); +EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX); +#define Perl_ppaddr_ptr Perl_Gppaddr_ptr +#define Perl_check_ptr Perl_Gcheck_ptr +#define Perl_fold_locale_ptr Perl_Gfold_locale_ptr +#endif END_EXTERN_C @@ -56,9 +69,9 @@ END_EXTERN_C START_EXTERN_C #ifndef DOINIT -EXT void *PL_force_link_funcs[]; +EXTCONST void * const PL_force_link_funcs[]; #else -EXT void *PL_force_link_funcs[] = { +EXTCONST void * const PL_force_link_funcs[] = { #undef PERLVAR #undef PERLVARA #undef PERLVARI @@ -67,6 +80,7 @@ EXT void *PL_force_link_funcs[] = { #define PERLVARA(v,n,t) PERLVAR(v,t) #define PERLVARI(v,t,i) PERLVAR(v,t) #define PERLVARIC(v,t,i) PERLVAR(v,t) +#define PERLVARISC(v,i) PERLVAR(v,char) #include "thrdvar.h" #include "intrpvar.h" @@ -76,6 +90,7 @@ EXT void *PL_force_link_funcs[] = { #undef PERLVARA #undef PERLVARI #undef PERLVARIC +#undef PERLVARISC }; #endif /* DOINIT */ @@ -921,6 +936,10 @@ END_EXTERN_C #define PL_No (*Perl_GNo_ptr(NULL)) #undef PL_Yes #define PL_Yes (*Perl_GYes_ptr(NULL)) +#undef PL_appctx +#define PL_appctx (*Perl_Gappctx_ptr(NULL)) +#undef PL_check +#define PL_check (*Perl_Gcheck_ptr(NULL)) #undef PL_csighandlerp #define PL_csighandlerp (*Perl_Gcsighandlerp_ptr(NULL)) #undef PL_curinterp @@ -929,24 +948,52 @@ END_EXTERN_C #define PL_do_undump (*Perl_Gdo_undump_ptr(NULL)) #undef PL_dollarzero_mutex #define PL_dollarzero_mutex (*Perl_Gdollarzero_mutex_ptr(NULL)) +#undef PL_fold_locale +#define PL_fold_locale (*Perl_Gfold_locale_ptr(NULL)) #undef PL_hexdigit #define PL_hexdigit (*Perl_Ghexdigit_ptr(NULL)) #undef PL_malloc_mutex #define PL_malloc_mutex (*Perl_Gmalloc_mutex_ptr(NULL)) +#undef PL_mmap_page_size +#define PL_mmap_page_size (*Perl_Gmmap_page_size_ptr(NULL)) #undef PL_op_mutex #define PL_op_mutex (*Perl_Gop_mutex_ptr(NULL)) +#undef PL_op_seq +#define PL_op_seq (*Perl_Gop_seq_ptr(NULL)) +#undef PL_op_sequence +#define PL_op_sequence (*Perl_Gop_sequence_ptr(NULL)) #undef PL_patleave #define PL_patleave (*Perl_Gpatleave_ptr(NULL)) +#undef PL_perlio_debug_fd +#define PL_perlio_debug_fd (*Perl_Gperlio_debug_fd_ptr(NULL)) +#undef PL_perlio_fd_refcnt +#define PL_perlio_fd_refcnt (*Perl_Gperlio_fd_refcnt_ptr(NULL)) +#undef PL_ppaddr +#define PL_ppaddr (*Perl_Gppaddr_ptr(NULL)) #undef PL_sh_path #define PL_sh_path (*Perl_Gsh_path_ptr(NULL)) +#undef PL_sig_defaulting +#define PL_sig_defaulting (*Perl_Gsig_defaulting_ptr(NULL)) +#undef PL_sig_handlers_initted +#define PL_sig_handlers_initted (*Perl_Gsig_handlers_initted_ptr(NULL)) +#undef PL_sig_ignoring +#define PL_sig_ignoring (*Perl_Gsig_ignoring_ptr(NULL)) +#undef PL_sig_sv +#define PL_sig_sv (*Perl_Gsig_sv_ptr(NULL)) +#undef PL_sig_trapped +#define PL_sig_trapped (*Perl_Gsig_trapped_ptr(NULL)) #undef PL_sigfpe_saved #define PL_sigfpe_saved (*Perl_Gsigfpe_saved_ptr(NULL)) #undef PL_sv_placeholder #define PL_sv_placeholder (*Perl_Gsv_placeholder_ptr(NULL)) #undef PL_thr_key #define PL_thr_key (*Perl_Gthr_key_ptr(NULL)) +#undef PL_timesbase +#define PL_timesbase (*Perl_Gtimesbase_ptr(NULL)) #undef PL_use_safe_putenv #define PL_use_safe_putenv (*Perl_Guse_safe_putenv_ptr(NULL)) +#undef PL_watch_pvx +#define PL_watch_pvx (*Perl_Gwatch_pvx_ptr(NULL)) #endif /* !PERL_CORE */ #endif /* MULTIPLICITY */ diff --git a/perlio.c b/perlio.c index 04677b8..9085480 100644 --- a/perlio.c +++ b/perlio.c @@ -56,6 +56,8 @@ #include "XSUB.h" +#define PERLIO_MAX_REFCOUNTABLE_FD 2048 + #ifdef __Lynx__ /* Missing proto on LynxOS */ int mkstemp(char*); @@ -250,7 +252,7 @@ PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) PerlIO * PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) { -#ifdef PERL_MICRO +#if defined(PERL_MICRO) || defined(SYMBIAN) return NULL; #else #ifdef PERL_IMPLICIT_SYS @@ -450,18 +452,17 @@ void PerlIO_debug(const char *fmt, ...) void PerlIO_debug(const char *fmt, ...) { - static int dbg = 0; va_list ap; dSYS; va_start(ap, fmt); - if (!dbg && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) { + if (!PL_perlio_debug_fd && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) { char *s = PerlEnv_getenv("PERLIO_DEBUG"); if (s && *s) - dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666); + PL_perlio_debug_fd = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666); else - dbg = -1; + PL_perlio_debug_fd = -1; } - if (dbg > 0) { + if (PL_perlio_debug_fd > 0) { dTHX; const char *s; #ifdef USE_ITHREADS @@ -474,7 +475,7 @@ PerlIO_debug(const char *fmt, ...) sprintf(buffer, "%.40s:%" IVdf " ", s, (IV) CopLINE(PL_curcop)); len = strlen(buffer); vsprintf(buffer+len, fmt, ap); - PerlLIO_write(dbg, buffer, strlen(buffer)); + PerlLIO_write(PL_perlio_debug_fd, buffer, strlen(buffer)); #else SV *sv = newSVpvn("", 0); STRLEN len; @@ -486,7 +487,7 @@ PerlIO_debug(const char *fmt, ...) Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); s = SvPV(sv, len); - PerlLIO_write(dbg, s, len); + PerlLIO_write(PL_perlio_debug_fd, s, len); SvREFCNT_dec(sv); #endif } @@ -740,6 +741,7 @@ PerlIO_get_layers(pTHX_ PerlIO *f) PerlIO_funcs * PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) { + dVAR; IV i; if ((SSize_t) len <= 0) len = strlen(name); @@ -1001,7 +1003,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) void PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) { - PerlIO_funcs *tab = &PerlIO_perlio; + PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio; #ifdef PERLIO_USING_CRLF tab = &PerlIO_crlf; #else @@ -1043,7 +1045,7 @@ PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) return -1; } -PerlIO_funcs PerlIO_remove = { +PERLIO_FUNCS_DECL(PerlIO_remove) = { sizeof(PerlIO_funcs), "pop", 0, @@ -1077,25 +1079,25 @@ PerlIO_default_layers(pTHX) { if (!PL_def_layerlist) { const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO"); - PerlIO_funcs *osLayer = &PerlIO_unix; + PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; PL_def_layerlist = PerlIO_list_alloc(aTHX); - PerlIO_define_layer(aTHX_ & PerlIO_unix); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); #if defined(WIN32) - PerlIO_define_layer(aTHX_ & PerlIO_win32); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32)); #if 0 osLayer = &PerlIO_win32; #endif #endif - PerlIO_define_layer(aTHX_ & PerlIO_raw); - PerlIO_define_layer(aTHX_ & PerlIO_perlio); - PerlIO_define_layer(aTHX_ & PerlIO_stdio); - PerlIO_define_layer(aTHX_ & PerlIO_crlf); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); #ifdef HAS_MMAP - PerlIO_define_layer(aTHX_ & PerlIO_mmap); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap)); #endif - PerlIO_define_layer(aTHX_ & PerlIO_utf8); - PerlIO_define_layer(aTHX_ & PerlIO_remove); - PerlIO_define_layer(aTHX_ & PerlIO_byte); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); PerlIO_list_push(aTHX_ PL_def_layerlist, PerlIO_find_layer(aTHX_ osLayer->name, 0, 0), &PL_sv_undef); @@ -1129,7 +1131,7 @@ PerlIO_default_layer(pTHX_ I32 n) PerlIO_list_t *av = PerlIO_default_layers(aTHX); if (n < 0) n += av->cur; - return PerlIO_layer_fetch(aTHX_ av, n, &PerlIO_stdio); + return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio)); } #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1) @@ -1147,7 +1149,7 @@ PerlIO_stdstreams(pTHX) } PerlIO * -PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg) +PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) { if (tab->fsize != sizeof(PerlIO_funcs)) { mismatch: @@ -1163,12 +1165,12 @@ PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg) if (l && f) { Zero(l, tab->size, char); l->next = *f; - l->tab = tab; + l->tab = (PerlIO_funcs*) tab; *f = l; PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, (mode) ? mode : "(Null)", (void*)arg); if (*l->tab->Pushed && - (*l->tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) { + (*l->tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { PerlIO_pop(aTHX_ f); return NULL; } @@ -1179,7 +1181,7 @@ PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg) PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, (mode) ? mode : "(Null)", (void*)arg); if (tab->Pushed && - (*tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) { + (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { return NULL; } } @@ -1332,7 +1334,7 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) /* Legacy binmode is now _defined_ as being equivalent to pushing :raw So code that used to be here is now in PerlIORaw_pushed(). */ - return PerlIO_push(aTHX_ f, &PerlIO_raw, Nullch, Nullsv) ? TRUE : FALSE; + return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), Nullch, Nullsv) ? TRUE : FALSE; } } @@ -1813,7 +1815,7 @@ PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) return -1; } -PerlIO_funcs PerlIO_utf8 = { +PERLIO_FUNCS_DECL(PerlIO_utf8) = { sizeof(PerlIO_funcs), "utf8", 0, @@ -1842,7 +1844,7 @@ PerlIO_funcs PerlIO_utf8 = { NULL, /* set_ptrcnt */ }; -PerlIO_funcs PerlIO_byte = { +PERLIO_FUNCS_DECL(PerlIO_byte) = { sizeof(PerlIO_funcs), "bytes", 0, @@ -1884,7 +1886,7 @@ PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, return NULL; } -PerlIO_funcs PerlIO_raw = { +PERLIO_FUNCS_DECL(PerlIO_raw) = { sizeof(PerlIO_funcs), "raw", 0, @@ -2032,7 +2034,7 @@ PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) */ Off_t old = PerlIO_tell(f); SSize_t done; - PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv); + PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", Nullsv); PerlIOSelf(f, PerlIOBuf)->posn = old; done = PerlIOBuf_unread(aTHX_ f, vbuf, count); return done; @@ -2195,30 +2197,31 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) return f; } -#define PERLIO_MAX_REFCOUNTABLE_FD 2048 #ifdef USE_THREADS perl_mutex PerlIO_mutex; #endif -int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD]; + +/* PL_perlio_fd_refcnt[] is in intrpvar.h */ void PerlIO_init(pTHX) { /* Place holder for stdstreams call ??? */ #ifdef USE_THREADS - MUTEX_INIT(&PerlIO_mutex); + MUTEX_INIT(&PerlIO_mutex); #endif } void PerlIOUnix_refcnt_inc(int fd) { + dTHX; if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { #ifdef USE_THREADS MUTEX_LOCK(&PerlIO_mutex); #endif - PerlIO_fd_refcnt[fd]++; - PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]); + PL_perlio_fd_refcnt[fd]++; + PerlIO_debug("fd %d refcnt=%d\n",fd,PL_perlio_fd_refcnt[fd]); #ifdef USE_THREADS MUTEX_UNLOCK(&PerlIO_mutex); #endif @@ -2228,12 +2231,13 @@ PerlIOUnix_refcnt_inc(int fd) int PerlIOUnix_refcnt_dec(int fd) { + dTHX; int cnt = 0; if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) { #ifdef USE_THREADS MUTEX_LOCK(&PerlIO_mutex); #endif - cnt = --PerlIO_fd_refcnt[fd]; + cnt = --PL_perlio_fd_refcnt[fd]; PerlIO_debug("fd %d refcnt=%d\n",fd,cnt); #ifdef USE_THREADS MUTEX_UNLOCK(&PerlIO_mutex); @@ -2263,7 +2267,7 @@ PerlIO_cleanup(pTHX) PerlIO_list_free(aTHX_ PL_known_layers); PL_known_layers = NULL; } - if(PL_def_layerlist) { + if (PL_def_layerlist) { PerlIO_list_free(aTHX_ PL_def_layerlist); PL_def_layerlist = NULL; } @@ -2479,6 +2483,10 @@ SSize_t PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { int fd = PerlIOSelf(f, PerlIOUnix)->fd; +#ifdef PERLIO_STD_SPECIAL + if (fd == 0) + return PERLIO_STD_IN(fd, vbuf, count); +#endif if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) || PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) { return 0; @@ -2505,6 +2513,10 @@ SSize_t PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { int fd = PerlIOSelf(f, PerlIOUnix)->fd; +#ifdef PERLIO_STD_SPECIAL + if (fd == 1 || fd == 2) + return PERLIO_STD_OUT(fd, vbuf, count); +#endif while (1) { SSize_t len = PerlLIO_write(fd, vbuf, count); if (len >= 0 || errno != EINTR) { @@ -2554,7 +2566,7 @@ PerlIOUnix_close(pTHX_ PerlIO *f) return code; } -PerlIO_funcs PerlIO_unix = { +PERLIO_FUNCS_DECL(PerlIO_unix) = { sizeof(PerlIO_funcs), "unix", sizeof(PerlIOUnix), @@ -2689,7 +2701,7 @@ PerlIO_importFILE(FILE *stdio, const char *mode) } fclose(f2); } - if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio, mode, Nullsv))) { + if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, Nullsv))) { s = PerlIOSelf(f, PerlIOStdio); s->stdio = stdio; } @@ -3303,7 +3315,7 @@ PerlIOStdio_fill(pTHX_ PerlIO *f) -PerlIO_funcs PerlIO_stdio = { +PERLIO_FUNCS_DECL(PerlIO_stdio) = { sizeof(PerlIO_funcs), "stdio", sizeof(PerlIOStdio), @@ -3368,7 +3380,7 @@ PerlIO_exportFILE(PerlIO * f, const char *mode) PerlIO *f2; /* De-link any lower layers so new :stdio sticks */ *f = NULL; - if ((f2 = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) { + if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, Nullsv))) { PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); s->stdio = stdio; /* Link previous lower layers under new one */ @@ -3403,6 +3415,7 @@ PerlIO_findFILE(PerlIO *f) void PerlIO_releaseFILE(PerlIO *p, FILE *f) { + dVAR; PerlIOl *l; while ((l = *p)) { if (l->tab == &PerlIO_stdio) { @@ -3890,7 +3903,7 @@ PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) -PerlIO_funcs PerlIO_perlio = { +PERLIO_FUNCS_DECL(PerlIO_perlio) = { sizeof(PerlIO_funcs), "perlio", sizeof(PerlIOBuf), @@ -4013,7 +4026,7 @@ PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) return got; } -PerlIO_funcs PerlIO_pending = { +PERLIO_FUNCS_DECL(PerlIO_pending) = { sizeof(PerlIO_funcs), "pending", sizeof(PerlIOBuf), @@ -4344,7 +4357,7 @@ PerlIOCrlf_binmode(pTHX_ PerlIO *f) return 0; } -PerlIO_funcs PerlIO_crlf = { +PERLIO_FUNCS_DECL(PerlIO_crlf) = { sizeof(PerlIO_funcs), "crlf", sizeof(PerlIOCrlf), @@ -4389,11 +4402,10 @@ typedef struct { STDCHAR *bbuf; /* malloced buffer if map fails */ } PerlIOMmap; -static size_t page_size = 0; - IV PerlIOMmap_map(pTHX_ PerlIO *f) { + dVAR; PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap); IV flags = PerlIOBase(f)->flags; IV code = 0; @@ -4408,43 +4420,9 @@ PerlIOMmap_map(pTHX_ PerlIO *f) SSize_t len = st.st_size - b->posn; if (len > 0) { Off_t posn; - if (!page_size) { -#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE)) - { - SETERRNO(0, SS_NORMAL); -# ifdef _SC_PAGESIZE - page_size = sysconf(_SC_PAGESIZE); -# else - page_size = sysconf(_SC_PAGE_SIZE); -# endif - if ((long) page_size < 0) { - if (errno) { - SV *error = ERRSV; - char *msg; - STRLEN n_a; - (void) SvUPGRADE(error, SVt_PV); - msg = SvPVx(error, n_a); - Perl_croak(aTHX_ "panic: sysconf: %s", - msg); - } - else - Perl_croak(aTHX_ - "panic: sysconf: pagesize unknown"); - } - } -#else -# ifdef HAS_GETPAGESIZE - page_size = getpagesize(); -# else -# if defined(I_SYS_PARAM) && defined(PAGESIZE) - page_size = PAGESIZE; /* compiletime, bad */ -# endif -# endif -#endif - if ((IV) page_size <= 0) - Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, - (IV) page_size); - } + if (PL_mmap_page_size <= 0) + Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, + PL_mmap_page_size); if (b->posn < 0) { /* * This is a hack - should never happen - open should @@ -4452,7 +4430,7 @@ PerlIOMmap_map(pTHX_ PerlIO *f) */ b->posn = PerlIO_tell(PerlIONext(f)); } - posn = (b->posn / page_size) * page_size; + posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size; len = st.st_size - posn; m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn); if (m->mptr && m->mptr != (Mmap_t) - 1) { @@ -4661,7 +4639,7 @@ PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) } -PerlIO_funcs PerlIO_mmap = { +PERLIO_FUNCS_DECL(PerlIO_mmap) = { sizeof(PerlIO_funcs), "mmap", sizeof(PerlIOMmap), @@ -4887,19 +4865,17 @@ PerlIO_tmpfile(void) { dTHX; PerlIO *f = NULL; - int fd = -1; #ifdef WIN32 - fd = win32_tmpfd(); + int fd = win32_tmpfd(); if (fd >= 0) f = PerlIO_fdopen(fd, "w+b"); #else /* WIN32 */ # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2) SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0); - /* * I have no idea how portable mkstemp() is ... NI-S */ - fd = mkstemp(SvPVX(sv)); + int fd = mkstemp(SvPVX(sv)); if (fd >= 0) { f = PerlIO_fdopen(fd, "w+"); if (f) @@ -4912,7 +4888,8 @@ PerlIO_tmpfile(void) if (stdio) { if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), - &PerlIO_stdio, "w+", Nullsv))) { + PERLIO_FUNCS_CAST(&PerlIO_stdio), + "w+", Nullsv))) { PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); if (s) @@ -5025,6 +5002,7 @@ vfprintf(FILE *fd, char *pat, char *args) int PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) { + dVAR; int val = vsprintf(s, fmt, ap); if (n >= 0) { if (strlen(s) >= (STRLEN) n) { diff --git a/perlio.h b/perlio.h index adea6b7..ba9b067 100644 --- a/perlio.h +++ b/perlio.h @@ -102,14 +102,28 @@ typedef PerlIOl *PerlIO; #define PerlIO PerlIO #define PERLIO_LAYERS 1 -extern void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab); -extern PerlIO_funcs *PerlIO_find_layer(pTHX_ const char *name, STRLEN len, - int load); -extern PerlIO *PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, - const char *mode, SV *arg); -extern void PerlIO_pop(pTHX_ PerlIO *f); -extern AV* PerlIO_get_layers(pTHX_ PerlIO *f); -extern void PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param); +/* Making the big PerlIO_funcs vtables const is good (enables placing + * them in the const section which is good for speed, security, and + * embeddability) but this cannot be done by default because of + * backward compatibility. */ +#ifdef PERLIO_FUNCS_CONST +#define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +#define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +#else +#define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +#define PERLIO_FUNCS_CAST(funcs) (funcs) +#endif + +PERL_EXPORT_C void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab); +PERL_EXPORT_C PerlIO_funcs *PerlIO_find_layer(pTHX_ const char *name, + STRLEN len, + int load); +PERL_EXPORT_C PerlIO *PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), + const char *mode, SV *arg); +PERL_EXPORT_C void PerlIO_pop(pTHX_ PerlIO *f); +PERL_EXPORT_C AV* PerlIO_get_layers(pTHX_ PerlIO *f); +PERL_EXPORT_C void PerlIO_clone(pTHX_ PerlInterpreter *proto, + CLONE_PARAMS *param); #endif /* PerlIO */ @@ -211,165 +225,165 @@ START_EXTERN_C #endif #endif #ifndef PerlIO_init -extern void PerlIO_init(pTHX); +PERL_EXPORT_C void PerlIO_init(pTHX); #endif #ifndef PerlIO_stdoutf -extern int PerlIO_stdoutf(const char *, ...) +PERL_EXPORT_C int PerlIO_stdoutf(const char *, ...) __attribute__format__(__printf__, 1, 2); #endif #ifndef PerlIO_puts -extern int PerlIO_puts(PerlIO *, const char *); +PERL_EXPORT_C int PerlIO_puts(PerlIO *, const char *); #endif #ifndef PerlIO_open -extern PerlIO *PerlIO_open(const char *, const char *); +PERL_EXPORT_C PerlIO *PerlIO_open(const char *, const char *); #endif #ifndef PerlIO_openn -extern PerlIO *PerlIO_openn(pTHX_ const char *layers, const char *mode, - int fd, int imode, int perm, PerlIO *old, - int narg, SV **arg); +PERL_EXPORT_C PerlIO *PerlIO_openn(pTHX_ const char *layers, const char *mode, + int fd, int imode, int perm, PerlIO *old, + int narg, SV **arg); #endif #ifndef PerlIO_eof -extern int PerlIO_eof(PerlIO *); +PERL_EXPORT_C int PerlIO_eof(PerlIO *); #endif #ifndef PerlIO_error -extern int PerlIO_error(PerlIO *); +PERL_EXPORT_C int PerlIO_error(PerlIO *); #endif #ifndef PerlIO_clearerr -extern void PerlIO_clearerr(PerlIO *); +PERL_EXPORT_C void PerlIO_clearerr(PerlIO *); #endif #ifndef PerlIO_getc -extern int PerlIO_getc(PerlIO *); +PERL_EXPORT_C int PerlIO_getc(PerlIO *); #endif #ifndef PerlIO_putc -extern int PerlIO_putc(PerlIO *, int); +PERL_EXPORT_C int PerlIO_putc(PerlIO *, int); #endif #ifndef PerlIO_ungetc -extern int PerlIO_ungetc(PerlIO *, int); +PERL_EXPORT_C int PerlIO_ungetc(PerlIO *, int); #endif #ifndef PerlIO_fdopen -extern PerlIO *PerlIO_fdopen(int, const char *); +PERL_EXPORT_C PerlIO *PerlIO_fdopen(int, const char *); #endif #ifndef PerlIO_importFILE -extern PerlIO *PerlIO_importFILE(FILE *, const char *); +PERL_EXPORT_C PerlIO *PerlIO_importFILE(FILE *, const char *); #endif #ifndef PerlIO_exportFILE -extern FILE *PerlIO_exportFILE(PerlIO *, const char *); +PERL_EXPORT_C FILE *PerlIO_exportFILE(PerlIO *, const char *); #endif #ifndef PerlIO_findFILE -extern FILE *PerlIO_findFILE(PerlIO *); +PERL_EXPORT_C FILE *PerlIO_findFILE(PerlIO *); #endif #ifndef PerlIO_releaseFILE -extern void PerlIO_releaseFILE(PerlIO *, FILE *); +PERL_EXPORT_C void PerlIO_releaseFILE(PerlIO *, FILE *); #endif #ifndef PerlIO_read -extern SSize_t PerlIO_read(PerlIO *, void *, Size_t); +PERL_EXPORT_C SSize_t PerlIO_read(PerlIO *, void *, Size_t); #endif #ifndef PerlIO_unread -extern SSize_t PerlIO_unread(PerlIO *, const void *, Size_t); +PERL_EXPORT_C SSize_t PerlIO_unread(PerlIO *, const void *, Size_t); #endif #ifndef PerlIO_write -extern SSize_t PerlIO_write(PerlIO *, const void *, Size_t); +PERL_EXPORT_C SSize_t PerlIO_write(PerlIO *, const void *, Size_t); #endif #ifndef PerlIO_setlinebuf -extern void PerlIO_setlinebuf(PerlIO *); +PERL_EXPORT_C void PerlIO_setlinebuf(PerlIO *); #endif #ifndef PerlIO_printf -extern int PerlIO_printf(PerlIO *, const char *, ...) +PERL_EXPORT_C int PerlIO_printf(PerlIO *, const char *, ...) __attribute__format__(__printf__, 2, 3); #endif #ifndef PerlIO_sprintf -extern int PerlIO_sprintf(char *, int, const char *, ...) +PERL_EXPORT_C int PerlIO_sprintf(char *, int, const char *, ...) __attribute__format__(__printf__, 3, 4); #endif #ifndef PerlIO_vprintf -extern int PerlIO_vprintf(PerlIO *, const char *, va_list); +PERL_EXPORT_C int PerlIO_vprintf(PerlIO *, const char *, va_list); #endif #ifndef PerlIO_tell -extern Off_t PerlIO_tell(PerlIO *); +PERL_EXPORT_C Off_t PerlIO_tell(PerlIO *); #endif #ifndef PerlIO_seek -extern int PerlIO_seek(PerlIO *, Off_t, int); +PERL_EXPORT_C int PerlIO_seek(PerlIO *, Off_t, int); #endif #ifndef PerlIO_rewind -extern void PerlIO_rewind(PerlIO *); +PERL_EXPORT_C void PerlIO_rewind(PerlIO *); #endif #ifndef PerlIO_has_base -extern int PerlIO_has_base(PerlIO *); +PERL_EXPORT_C int PerlIO_has_base(PerlIO *); #endif #ifndef PerlIO_has_cntptr -extern int PerlIO_has_cntptr(PerlIO *); +PERL_EXPORT_C int PerlIO_has_cntptr(PerlIO *); #endif #ifndef PerlIO_fast_gets -extern int PerlIO_fast_gets(PerlIO *); +PERL_EXPORT_C int PerlIO_fast_gets(PerlIO *); #endif #ifndef PerlIO_canset_cnt -extern int PerlIO_canset_cnt(PerlIO *); +PERL_EXPORT_C int PerlIO_canset_cnt(PerlIO *); #endif #ifndef PerlIO_get_ptr -extern STDCHAR *PerlIO_get_ptr(PerlIO *); +PERL_EXPORT_C STDCHAR *PerlIO_get_ptr(PerlIO *); #endif #ifndef PerlIO_get_cnt -extern int PerlIO_get_cnt(PerlIO *); +PERL_EXPORT_C int PerlIO_get_cnt(PerlIO *); #endif #ifndef PerlIO_set_cnt -extern void PerlIO_set_cnt(PerlIO *, int); +PERL_EXPORT_C void PerlIO_set_cnt(PerlIO *, int); #endif #ifndef PerlIO_set_ptrcnt -extern void PerlIO_set_ptrcnt(PerlIO *, STDCHAR *, int); +PERL_EXPORT_C void PerlIO_set_ptrcnt(PerlIO *, STDCHAR *, int); #endif #ifndef PerlIO_get_base -extern STDCHAR *PerlIO_get_base(PerlIO *); +PERL_EXPORT_C STDCHAR *PerlIO_get_base(PerlIO *); #endif #ifndef PerlIO_get_bufsiz -extern int PerlIO_get_bufsiz(PerlIO *); +PERL_EXPORT_C int PerlIO_get_bufsiz(PerlIO *); #endif #ifndef PerlIO_tmpfile -extern PerlIO *PerlIO_tmpfile(void); +PERL_EXPORT_C PerlIO *PerlIO_tmpfile(void); #endif #ifndef PerlIO_stdin -extern PerlIO *PerlIO_stdin(void); +PERL_EXPORT_C PerlIO *PerlIO_stdin(void); #endif #ifndef PerlIO_stdout -extern PerlIO *PerlIO_stdout(void); +PERL_EXPORT_C PerlIO *PerlIO_stdout(void); #endif #ifndef PerlIO_stderr -extern PerlIO *PerlIO_stderr(void); +PERL_EXPORT_C PerlIO *PerlIO_stderr(void); #endif #ifndef PerlIO_getpos -extern int PerlIO_getpos(PerlIO *, SV *); +PERL_EXPORT_C int PerlIO_getpos(PerlIO *, SV *); #endif #ifndef PerlIO_setpos -extern int PerlIO_setpos(PerlIO *, SV *); +PERL_EXPORT_C int PerlIO_setpos(PerlIO *, SV *); #endif #ifndef PerlIO_fdupopen -extern PerlIO *PerlIO_fdupopen(pTHX_ PerlIO *, CLONE_PARAMS *, int); +PERL_EXPORT_C PerlIO *PerlIO_fdupopen(pTHX_ PerlIO *, CLONE_PARAMS *, int); #endif #if !defined(PerlIO_modestr) && !defined(PERLIO_IS_STDIO) -extern char *PerlIO_modestr(PerlIO *, char *buf); +PERL_EXPORT_C char *PerlIO_modestr(PerlIO *, char *buf); #endif #ifndef PerlIO_isutf8 -extern int PerlIO_isutf8(PerlIO *); +PERL_EXPORT_C int PerlIO_isutf8(PerlIO *); #endif #ifndef PerlIO_apply_layers -extern int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, - const char *names); +PERL_EXPORT_C int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, + const char *names); #endif #ifndef PerlIO_binmode -extern int PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int omode, - const char *names); +PERL_EXPORT_C int PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int omode, + const char *names); #endif #ifndef PerlIO_getname -extern char *PerlIO_getname(PerlIO *, char *); +PERL_EXPORT_C char *PerlIO_getname(PerlIO *, char *); #endif -extern void PerlIO_destruct(pTHX); +PERL_EXPORT_C void PerlIO_destruct(pTHX); -extern int PerlIO_intmode2str(int rawmode, char *mode, int *writing); +PERL_EXPORT_C int PerlIO_intmode2str(int rawmode, char *mode, int *writing); #ifdef PERLIO_LAYERS -extern void PerlIO_cleanup(pTHX); +PERL_EXPORT_C void PerlIO_cleanup(pTHX); -extern void PerlIO_debug(const char *fmt, ...); +PERL_EXPORT_C void PerlIO_debug(const char *fmt, ...); typedef struct PerlIO_list_s PerlIO_list_t; diff --git a/perliol.h b/perliol.h index 80e7c7d..8697d9b 100644 --- a/perliol.h +++ b/perliol.h @@ -96,23 +96,29 @@ struct _PerlIO { #define PerlIOValid(f) ((f) && *(f)) /*--------------------------------------------------------------------------------------*/ -/* Data exports - EXT rather than extern is needed for Cygwin */ -EXT PerlIO_funcs PerlIO_unix; -EXT PerlIO_funcs PerlIO_perlio; -EXT PerlIO_funcs PerlIO_stdio; -EXT PerlIO_funcs PerlIO_crlf; -EXT PerlIO_funcs PerlIO_utf8; -EXT PerlIO_funcs PerlIO_byte; -EXT PerlIO_funcs PerlIO_raw; -EXT PerlIO_funcs PerlIO_pending; +/* Data exports - EXTCONST rather than extern is needed for Cygwin */ +#undef EXTPERLIO +#ifdef PERLIO_FUNCS_CONST +#define EXTPERLIO EXTCONST +#else +#define EXTPERLIO EXT +#endif +EXTPERLIO PerlIO_funcs PerlIO_unix; +EXTPERLIO PerlIO_funcs PerlIO_perlio; +EXTPERLIO PerlIO_funcs PerlIO_stdio; +EXTPERLIO PerlIO_funcs PerlIO_crlf; +EXTPERLIO PerlIO_funcs PerlIO_utf8; +EXTPERLIO PerlIO_funcs PerlIO_byte; +EXTPERLIO PerlIO_funcs PerlIO_raw; +EXTPERLIO PerlIO_funcs PerlIO_pending; #ifdef HAS_MMAP -EXT PerlIO_funcs PerlIO_mmap; +EXTPERLIO PerlIO_funcs PerlIO_mmap; #endif #ifdef WIN32 -EXT PerlIO_funcs PerlIO_win32; +EXTPERLIO PerlIO_funcs PerlIO_win32; #endif -extern PerlIO *PerlIO_allocate(pTHX); -extern SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n); +PERL_EXPORT_C PerlIO *PerlIO_allocate(pTHX); +PERL_EXPORT_C SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n); #define PerlIOArg PerlIO_arg_fetch(layers,n) #ifdef PERLIO_USING_CRLF @@ -124,23 +130,24 @@ extern SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n); /*--------------------------------------------------------------------------------------*/ /* Generic, or stub layer functions */ -extern IV PerlIOBase_fileno(pTHX_ PerlIO *f); -extern PerlIO *PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); -extern IV PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); -extern IV PerlIOBase_popped(pTHX_ PerlIO *f); -extern IV PerlIOBase_binmode(pTHX_ PerlIO *f); -extern SSize_t PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); -extern SSize_t PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, - Size_t count); -extern IV PerlIOBase_eof(pTHX_ PerlIO *f); -extern IV PerlIOBase_error(pTHX_ PerlIO *f); -extern void PerlIOBase_clearerr(pTHX_ PerlIO *f); -extern IV PerlIOBase_close(pTHX_ PerlIO *f); -extern void PerlIOBase_setlinebuf(pTHX_ PerlIO *f); -extern void PerlIOBase_flush_linebuf(pTHX); - -extern IV PerlIOBase_noop_ok(pTHX_ PerlIO *f); -extern IV PerlIOBase_noop_fail(pTHX_ PerlIO *f); +PERL_EXPORT_C IV PerlIOBase_fileno(pTHX_ PerlIO *f); +PERL_EXPORT_C PerlIO *PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); +PERL_EXPORT_C IV PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); +PERL_EXPORT_C IV PerlIOBase_popped(pTHX_ PerlIO *f); +PERL_EXPORT_C IV PerlIOBase_binmode(pTHX_ PerlIO *f); +PERL_EXPORT_C SSize_t PerlIOBase_read(pTHX_ PerlIO *f, + void *vbuf, Size_t count); +PERL_EXPORT_C SSize_t PerlIOBase_unread(pTHX_ PerlIO *f, + const void *vbuf, Size_t count); +PERL_EXPORT_C IV PerlIOBase_eof(pTHX_ PerlIO *f); +PERL_EXPORT_C IV PerlIOBase_error(pTHX_ PerlIO *f); +PERL_EXPORT_C void PerlIOBase_clearerr(pTHX_ PerlIO *f); +PERL_EXPORT_C IV PerlIOBase_close(pTHX_ PerlIO *f); +PERL_EXPORT_C void PerlIOBase_setlinebuf(pTHX_ PerlIO *f); +PERL_EXPORT_C void PerlIOBase_flush_linebuf(pTHX); + +PERL_EXPORT_C IV PerlIOBase_noop_ok(pTHX_ PerlIO *f); +PERL_EXPORT_C IV PerlIOBase_noop_fail(pTHX_ PerlIO *f); /*--------------------------------------------------------------------------------------*/ /* perlio buffer layer @@ -158,36 +165,36 @@ typedef struct { IV oneword; /* Emergency buffer */ } PerlIOBuf; -extern int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, +PERL_EXPORT_C int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n, IV max); -extern int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names); -extern void PerlIO_list_free(pTHX_ PerlIO_list_t *list); -extern PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def); +PERL_EXPORT_C int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names); +PERL_EXPORT_C void PerlIO_list_free(pTHX_ PerlIO_list_t *list); +PERL_EXPORT_C PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def); -extern SV *PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param); -extern PerlIO *PerlIOBuf_open(pTHX_ PerlIO_funcs *self, +PERL_EXPORT_C SV *PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param); +PERL_EXPORT_C PerlIO *PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args); -extern IV PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); -extern IV PerlIOBuf_popped(pTHX_ PerlIO *f); -extern PerlIO *PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); -extern SSize_t PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); -extern SSize_t PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count); -extern SSize_t PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count); -extern IV PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence); -extern Off_t PerlIOBuf_tell(pTHX_ PerlIO *f); -extern IV PerlIOBuf_close(pTHX_ PerlIO *f); -extern IV PerlIOBuf_flush(pTHX_ PerlIO *f); -extern IV PerlIOBuf_fill(pTHX_ PerlIO *f); -extern STDCHAR *PerlIOBuf_get_base(pTHX_ PerlIO *f); -extern Size_t PerlIOBuf_bufsiz(pTHX_ PerlIO *f); -extern STDCHAR *PerlIOBuf_get_ptr(pTHX_ PerlIO *f); -extern SSize_t PerlIOBuf_get_cnt(pTHX_ PerlIO *f); -extern void PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt); - -extern int PerlIOUnix_oflags(const char *mode); +PERL_EXPORT_C IV PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); +PERL_EXPORT_C IV PerlIOBuf_popped(pTHX_ PerlIO *f); +PERL_EXPORT_C PerlIO *PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags); +PERL_EXPORT_C SSize_t PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count); +PERL_EXPORT_C SSize_t PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count); +PERL_EXPORT_C SSize_t PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count); +PERL_EXPORT_C IV PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence); +PERL_EXPORT_C Off_t PerlIOBuf_tell(pTHX_ PerlIO *f); +PERL_EXPORT_C IV PerlIOBuf_close(pTHX_ PerlIO *f); +PERL_EXPORT_C IV PerlIOBuf_flush(pTHX_ PerlIO *f); +PERL_EXPORT_C IV PerlIOBuf_fill(pTHX_ PerlIO *f); +PERL_EXPORT_C STDCHAR *PerlIOBuf_get_base(pTHX_ PerlIO *f); +PERL_EXPORT_C Size_t PerlIOBuf_bufsiz(pTHX_ PerlIO *f); +PERL_EXPORT_C STDCHAR *PerlIOBuf_get_ptr(pTHX_ PerlIO *f); +PERL_EXPORT_C SSize_t PerlIOBuf_get_cnt(pTHX_ PerlIO *f); +PERL_EXPORT_C void PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt); + +PERL_EXPORT_C int PerlIOUnix_oflags(const char *mode); /*--------------------------------------------------------------------------------------*/ diff --git a/perlvars.h b/perlvars.h index 00b0e1f..2ddd0ac 100644 --- a/perlvars.h +++ b/perlvars.h @@ -31,11 +31,12 @@ PERLVAR(Gcurinterp, PerlInterpreter *) PERLVAR(Gthr_key, perl_key) /* key to retrieve per-thread struct */ #endif -/* constants (these are not literals to facilitate pointer comparisons) */ -PERLVARIC(GYes, char *, "1") -PERLVARIC(GNo, char *, "") -PERLVARIC(Ghexdigit, char *, "0123456789abcdef0123456789ABCDEF") -PERLVARIC(Gpatleave, char *, "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}") +/* constants (these are not literals to facilitate pointer comparisons) + * (PERLVARISC really does create variables, despite its looks) */ +PERLVARISC(GYes, "1") +PERLVARISC(GNo, "") +PERLVARISC(Ghexdigit, "0123456789abcdef0123456789ABCDEF") +PERLVARISC(Gpatleave, "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}") /* XXX does anyone even use this? */ PERLVARI(Gdo_undump, bool, FALSE) /* -u or dump seen? */ @@ -72,3 +73,55 @@ PERLVARI(Gcsighandlerp, Sighandler_t, &Perl_csighandler) /* Pointer to C-level s #ifndef PERL_USE_SAFE_PUTENV PERLVARI(Guse_safe_putenv, int, 1) #endif + +#ifdef USE_PERLIO +PERLVARA(Gperlio_fd_refcnt, 2048, int) /* PERLIO_MAX_REFCOUNTABLE_FD */ +PERLVARI(Gperlio_debug_fd, int, 0) /* the fd to write perlio debug into, 0 means not set yet */ +#endif + +#ifdef HAS_MMAP +PERLVARI(Gmmap_page_size, IV, 0) +#endif + +#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS) +PERLVARI(Gsig_handlers_initted, int, 0) +#endif +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS +PERLVARA(Gsig_ignoring, SIG_SIZE, int) /* which signals we are ignoring */ +#endif +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS +PERLVAR(Gsig_defaulting, SIG_SIZE, int) +#endif + +#ifndef PERL_IMPLICIT_CONTEXT +PERLVAR(Gsig_sv, SV*) +#endif + +/* XXX signals are process-wide anyway, so we + * ignore the implications of this for threading */ +#ifndef HAS_SIGACTION +PERLVARI(Gsig_trapped, int, 0) +#endif + +#ifdef DEBUGGING +PERLVAR(Gwatch_pvx, char*) +#endif + +#ifdef PERL_GLOBAL_STRUCT +PERLVAR(Gppaddr, Perl_ppaddr_t*) /* or opcode.h */ +PERLVAR(Gcheck, Perl_check_t *) /* or opcode.h */ +PERLVARA(Gfold_locale, 256, unsigned char) /* or perl.h */ +#endif + +#ifdef PERL_NEED_APPCTX +PERLVAR(Gappctx, void*) /* the application context */ +#endif + +PERLVAR(Gop_sequence, HV*) /* dump.c */ +PERLVARI(Gop_seq, UV, 0) /* dump.c */ + +#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE) +PERLVAR(Gtimesbase, struct tms) +#endif + + diff --git a/pod.lst b/pod.lst index 46c7a83..52a4cf5 100644 --- a/pod.lst +++ b/pod.lst @@ -178,6 +178,7 @@ r perlos400 Perl notes for OS/400 r perlplan9 Perl notes for Plan 9 r perlqnx Perl notes for QNX r perlsolaris Perl notes for Solaris +r perlsymbian Perl notes for Symbian r perltru64 Perl notes for Tru64 r perluts Perl notes for UTS r perlvmesa Perl notes for VM/ESA diff --git a/pod/perl.pod b/pod/perl.pod index d1365a2..ba24f7c 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -189,6 +189,7 @@ For ease of access, the Perl manual has been split up into several sections. perlplan9 Perl notes for Plan 9 perlqnx Perl notes for QNX perlsolaris Perl notes for Solaris + perlsymbian Perl notes for Symbian perltru64 Perl notes for Tru64 perluts Perl notes for UTS perlvmesa Perl notes for VM/ESA diff --git a/pod/perlguts.pod b/pod/perlguts.pod index d95d3e4..df90f9e 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1871,6 +1871,26 @@ PERL_IMPLICIT_CONTEXT is also normally defined, and enables the support for passing in a "hidden" first argument that represents all three data structures. +Two other "encapsulation" macros are the PERL_GLOBAL_STRUCT and +PERL_GLOBAL_STRUCT_PRIVATE (the latter turns on the former, and the +former turns on MULTIPLICITY.) The PERL_GLOBAL_STRUCT causes all the +internal variables of Perl to be wrapped inside a single global struct, +struct perl_vars, accessible as (globals) &PL_Vars or PL_VarsPtr or +the function Perl_GetVars(). The PERL_GLOBAL_STRUCT_PRIVATE goes +one step further, there is still a single struct (allocated in main() +either from heap or from stack) but there are no global data symbols +pointing to it. In either case the global struct should be initialised +as the very first thing in main() using Perl_init_global_struct() and +correspondingly tear it down after perl_free() using Perl_free_global_struct(), +please see F for usage details. You may also need +to use C in your coding to "declare the global variables" +when you are using them. dTHX does this for you automatically. + +For backward compatibility reasons defining just PERL_GLOBAL_STRUCT +doesn't actually hide all symbols inside a big global struct: some +PerlIO_xxx vtables are left visible. The PERL_GLOBAL_STRUCT_PRIVATE +then hides everything (see how the PERLIO_FUNCS_DECL is used). + All this obviously requires a way for the Perl internal functions to be either subroutines taking some kind of structure as the first argument, or subroutines taking nothing as the first argument. To @@ -2072,6 +2092,13 @@ Never add a comma after C yourself--always use the form of the macro with the underscore for functions that take explicit arguments, or the form without the argument for functions with no explicit arguments. +If one is compiling Perl with the C<-DPERL_GLOBAL_STRUCT> the C +definition is needed if the Perl global variables (see F +or F) are accessed in the function and C is not +used (the C includes the C if necessary). One notices +the need for C only with the said compile-time define, because +otherwise the Perl global variables are visible as-is. + =head2 Should I do anything special if I call perl from multiple threads? If you create interpreters in one thread and then proceed to call them in diff --git a/pod/perlintern.pod b/pod/perlintern.pod index 6ff0156..006c66c 100644 --- a/pod/perlintern.pod +++ b/pod/perlintern.pod @@ -135,6 +135,16 @@ compiling pad (lvalue). Note that C is hijacked for this purpose. =for hackers Found in file pad.h +=item PAD_COMPNAME_GEN_set + +Sets the generation number of the name at offset C in the current +ling pad (lvalue) to C. Note that C is hijacked for this purpose. + + STRLEN PAD_COMPNAME_GEN_set(PADOFFSET po, int gen) + +=for hackers +Found in file pad.h + =item PAD_COMPNAME_OURSTASH Return the stash associated with an C variable. diff --git a/pp.c b/pp.c index 3b52e71..e3773b2 100644 --- a/pp.c +++ b/pp.c @@ -2524,7 +2524,7 @@ STATIC PP(pp_i_modulo_0) { /* This is the vanilla old i_modulo. */ - dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -2541,7 +2541,7 @@ PP(pp_i_modulo_1) /* This is the i_modulo with the workaround for the _moddi3 bug * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). * See below for pp_i_modulo. */ - dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -2554,7 +2554,7 @@ PP(pp_i_modulo_1) PP(pp_i_modulo) { - dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -3396,8 +3396,8 @@ PP(pp_chr) PP(pp_crypt) { - dSP; dTARGET; #ifdef HAS_CRYPT + dSP; dTARGET; dPOPTOPssrl; STRLEN n_a; STRLEN len; @@ -4145,7 +4145,7 @@ PP(pp_anonhash) PP(pp_splice) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; register AV *ary = (AV*)*++MARK; register SV **src; register SV **dst; @@ -4352,7 +4352,7 @@ PP(pp_splice) PP(pp_push) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv = &PL_sv_undef; MAGIC *mg; @@ -4407,7 +4407,7 @@ PP(pp_shift) PP(pp_unshift) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv; register I32 i = 0; @@ -4509,7 +4509,7 @@ PP(pp_reverse) PP(pp_split) { - dSP; dTARG; + dVAR; dSP; dTARG; AV *ary; register IV limit = POPi; /* note, negative is forever */ SV *sv = POPs; diff --git a/pp_ctl.c b/pp_ctl.c index 79c38f0..2db8d7e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -890,7 +890,7 @@ PP(pp_formline) PP(pp_grepstart) { - dSP; + dVAR; dSP; SV *src; if (PL_stack_base + *PL_markstack_ptr == SP) { @@ -932,7 +932,7 @@ PP(pp_mapstart) PP(pp_mapwhile) { - dSP; + dVAR; dSP; I32 gimme = GIMME_V; I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ I32 count; @@ -1184,7 +1184,7 @@ PP(pp_flop) /* Control. */ -static const char *context_name[] = { +static const char * const context_name[] = { "pseudo-block", "subroutine", "eval", @@ -1385,6 +1385,7 @@ Perl_qerror(pTHX_ SV *err) OP * Perl_die_where(pTHX_ const char *message, STRLEN msglen) { + dVAR; STRLEN n_a; if (PL_in_eval) { @@ -1728,6 +1729,7 @@ PP(pp_lineseq) PP(pp_dbstate) { + dVAR; PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; @@ -1779,7 +1781,7 @@ PP(pp_scope) PP(pp_enteriter) { - dSP; dMARK; + dVAR; dSP; dMARK; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; SV **svp; @@ -1866,7 +1868,7 @@ PP(pp_enteriter) PP(pp_enterloop) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; @@ -1882,7 +1884,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -1922,7 +1924,7 @@ PP(pp_leaveloop) PP(pp_return) { - dSP; dMARK; + dVAR; dSP; dMARK; I32 cxix; register PERL_CONTEXT *cx; bool popsub2 = FALSE; @@ -2037,7 +2039,7 @@ PP(pp_return) PP(pp_last) { - dSP; + dVAR; dSP; I32 cxix; register PERL_CONTEXT *cx; I32 pop2 = 0; @@ -2125,6 +2127,7 @@ PP(pp_last) PP(pp_next) { + dVAR; I32 cxix; register PERL_CONTEXT *cx; I32 inner; @@ -2153,6 +2156,7 @@ PP(pp_next) PP(pp_redo) { + dVAR; I32 cxix; register PERL_CONTEXT *cx; I32 oldsave; @@ -2232,7 +2236,7 @@ PP(pp_dump) PP(pp_goto) { - dSP; + dVAR; dSP; OP *retop = 0; I32 ix; register PERL_CONTEXT *cx; @@ -2732,7 +2736,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) /* startop op_free() this to undo. */ /* code Short string id of the caller. */ { - dSP; /* Make POPBLOCK work. */ + dVAR; dSP; /* Make POPBLOCK work. */ PERL_CONTEXT *cx; SV **newsp; I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */ @@ -2864,7 +2868,7 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) STATIC OP * S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { - dSP; + dVAR; dSP; OP *saveop = PL_op; PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) @@ -3036,7 +3040,7 @@ S_doopen_pm(pTHX_ const char *name, const char *mode) PP(pp_require) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; SV *sv; char *name; @@ -3239,15 +3243,29 @@ PP(pp_require) MacPerl_CanonDir(name, buf2, 1); Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':')); #else -#ifdef VMS +# ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); -#else +# else +# ifdef SYMBIAN + if (PL_origfilename[0] && + PL_origfilename[1] == ':' && + !(dir[0] && dir[1] == ':')) + Perl_sv_setpvf(aTHX_ namesv, + "%c:%s\\%s", + PL_origfilename[0], + dir, name); + else + Perl_sv_setpvf(aTHX_ namesv, + "%s\\%s", + dir, name); +# else Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); -#endif +# endif +# endif #endif TAINT_PROPER("require"); tryname = SvPVX(namesv); @@ -3364,7 +3382,7 @@ PP(pp_dofile) PP(pp_entereval) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; dPOPss; I32 gimme = GIMME_V, was = PL_sub_generation; @@ -3448,7 +3466,7 @@ PP(pp_entereval) PP(pp_leaveeval) { - dSP; + dVAR; dSP; register SV **mark; SV **newsp; PMOP *newpm; @@ -3516,7 +3534,7 @@ PP(pp_leaveeval) PP(pp_entertry) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; @@ -3535,7 +3553,7 @@ PP(pp_entertry) PP(pp_leavetry) { - dSP; + dVAR; dSP; register SV **mark; SV **newsp; PMOP *newpm; @@ -3829,6 +3847,7 @@ S_num_overflow(NV value, I32 fldsize, I32 frcsize) static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) { + dVAR; SV *datasv = FILTER_DATA(idx); int filter_has_file = IoLINES(datasv); GV *filter_child_proc = (GV *)IoFMT_GV(datasv); diff --git a/pp_hot.c b/pp_hot.c index ba724ff..767188b 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -571,7 +571,7 @@ PP(pp_pushre) PP(pp_print) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; GV *gv; IO *io; register PerlIO *fp; @@ -943,7 +943,7 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) PP(pp_aassign) { - dSP; + dVAR; dSP; SV **lastlelem = PL_stack_sp; SV **lastrelem = PL_stack_base + POPMARK; SV **firstrelem = PL_stack_base + POPMARK + 1; @@ -1444,7 +1444,7 @@ ret_no: OP * Perl_do_readline(pTHX) { - dSP; dTARGETSTACKED; + dVAR; dSP; dTARGETSTACKED; register SV *sv; STRLEN tmplen = 0; STRLEN offset; @@ -1642,7 +1642,7 @@ Perl_do_readline(pTHX) PP(pp_enter) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme = OP_GIMME(PL_op, -1); @@ -1752,7 +1752,7 @@ PP(pp_helem) PP(pp_leave) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; register SV **mark; SV **newsp; @@ -2287,7 +2287,7 @@ ret_no: PP(pp_grepwhile) { - dSP; + dVAR; dSP; if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; @@ -2338,7 +2338,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - dSP; + dVAR; dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2398,7 +2398,7 @@ PP(pp_leavesub) * get any slower by more conditions */ PP(pp_leavesublv) { - dSP; + dVAR; dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2593,7 +2593,7 @@ S_get_db_sub(pTHX_ SV **svp, CV *cv) PP(pp_entersub) { - dSP; dPOPss; + dVAR; dSP; dPOPss; GV *gv; HV *stash; register CV *cv; diff --git a/pp_pack.c b/pp_pack.c index 5ee841b..9a7cc53 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -1177,7 +1177,7 @@ STATIC I32 S_unpack_rec(pTHX_ tempsym_t* symptr, char *s, char *strbeg, char *strend, char **new_s ) { - dSP; + dVAR; dSP; SV *sv; I32 start_sp_offset = SP - PL_stack_base; howlen_t howlen; diff --git a/pp_sort.c b/pp_sort.c index 380194d..649375a 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -1490,7 +1490,7 @@ S_sortsv_desc(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp) PP(pp_sort) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; register SV **p1 = ORIGMARK+1, **p2; register I32 max, i; AV* av = Nullav; @@ -1714,6 +1714,7 @@ PP(pp_sort) static I32 sortcv(pTHX_ SV *a, SV *b) { + dVAR; I32 oldsaveix = PL_savestack_ix; I32 oldscopeix = PL_scopestack_ix; I32 result; @@ -1737,6 +1738,7 @@ sortcv(pTHX_ SV *a, SV *b) static I32 sortcv_stacked(pTHX_ SV *a, SV *b) { + dVAR; I32 oldsaveix = PL_savestack_ix; I32 oldscopeix = PL_scopestack_ix; I32 result; @@ -1778,7 +1780,7 @@ sortcv_stacked(pTHX_ SV *a, SV *b) static I32 sortcv_xsub(pTHX_ SV *a, SV *b) { - dSP; + dVAR; dSP; I32 oldsaveix = PL_savestack_ix; I32 oldscopeix = PL_scopestack_ix; I32 result; diff --git a/pp_sys.c b/pp_sys.c index 300ea6d..d908a1c 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -118,7 +118,12 @@ extern int h_errno; # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */ # undef my_chsize # endif -# define my_chsize PerlLIO_chsize +#else +# ifdef HAS_TRUNCATE +# define my_chsize PerlLIO_chsize +# else +I32 my_chsize(int fd, Off_t length); +# endif #endif #ifdef HAS_FLOCK @@ -167,7 +172,7 @@ extern int h_errno; #endif /* no flock() */ #define ZBTLEN 10 -static char zero_but_true[ZBTLEN + 1] = "0 but true"; +static const char zero_but_true[ZBTLEN + 1] = "0 but true"; #if defined(I_SYS_ACCESS) && !defined(R_OK) # include @@ -380,6 +385,7 @@ PP(pp_backtick) PP(pp_glob) { + dVAR; OP *result; tryAMAGICunTARGET(iter, -1); @@ -517,7 +523,7 @@ PP(pp_die) PP(pp_open) { - dSP; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; GV *gv; @@ -568,7 +574,7 @@ PP(pp_open) PP(pp_close) { - dSP; + dVAR; dSP; GV *gv; IO *io; MAGIC *mg; @@ -653,7 +659,7 @@ badexit: PP(pp_fileno) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -691,8 +697,9 @@ PP(pp_fileno) PP(pp_umask) { - dSP; dTARGET; + dSP; #ifdef HAS_UMASK + dTARGET; Mode_t anum; if (MAXARG < 1) { @@ -716,7 +723,7 @@ PP(pp_umask) PP(pp_binmode) { - dSP; + dVAR; dSP; GV *gv; IO *io; PerlIO *fp; @@ -776,8 +783,7 @@ PP(pp_binmode) PP(pp_tie) { - dSP; - dMARK; + dVAR; dSP; dMARK; SV *varsv; HV* stash; GV *gv; @@ -866,7 +872,7 @@ PP(pp_tie) PP(pp_untie) { - dSP; + dVAR; dSP; MAGIC *mg; SV *sv = POPs; char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) @@ -926,7 +932,7 @@ PP(pp_tied) PP(pp_dbmopen) { - dSP; + dVAR; dSP; HV *hv; dPOPPOPssrl; HV* stash; @@ -1190,7 +1196,7 @@ PP(pp_select) PP(pp_getc) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io = NULL; MAGIC *mg; @@ -1247,6 +1253,7 @@ PP(pp_read) STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { + dVAR; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; @@ -1308,7 +1315,7 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - dSP; + dVAR; dSP; GV *gv = cxstack[cxstack_ix].blk_sub.gv; register IO *io = GvIOp(gv); PerlIO *ofp = IoOFP(io); @@ -1436,7 +1443,7 @@ PP(pp_leavewrite) PP(pp_prtf) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; GV *gv; IO *io; PerlIO *fp; @@ -1540,7 +1547,7 @@ PP(pp_sysopen) PP(pp_sysread) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; int offset; GV *gv; IO *io; @@ -1679,7 +1686,7 @@ PP(pp_sysread) (should be 2 * length + offset + 1, or possibly something longer if PL_encoding is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); - if (offset > bufsize) { /* Zero any newly allocated space */ + if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */ Zero(buffer+bufsize, offset-bufsize, char); } buffer = buffer + offset; @@ -1794,7 +1801,7 @@ PP(pp_sysread) PP(pp_syswrite) { - dSP; + dVAR; dSP; int items = (SP - PL_stack_base) - TOPMARK; if (items == 2) { SV *sv; @@ -1808,7 +1815,7 @@ PP(pp_syswrite) PP(pp_send) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; GV *gv; IO *io; SV *bufsv; @@ -1950,7 +1957,7 @@ PP(pp_recv) PP(pp_eof) { - dSP; + dVAR; dSP; GV *gv; IO *io; MAGIC *mg; @@ -1997,7 +2004,7 @@ PP(pp_eof) PP(pp_tell) { - dSP; dTARGET; + dVAR; dSP; dTARGET; GV *gv; IO *io; MAGIC *mg; @@ -2035,7 +2042,7 @@ PP(pp_seek) PP(pp_sysseek) { - dSP; + dVAR; dSP; GV *gv; IO *io; int whence = POPi; @@ -3963,7 +3970,7 @@ nope: PP(pp_telldir) { #if defined(HAS_TELLDIR) || defined(telldir) - dSP; dTARGET; + dVAR; dSP; dTARGET; /* XXX does _anyone_ need this? --AD 2/20/1998 */ /* XXX netbsd still seemed to. XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. @@ -4174,7 +4181,6 @@ PP(pp_system) I32 value; STRLEN n_a; int result; - I32 did_pipes = 0; if (PL_tainting) { TAINT_ENV(); @@ -4191,6 +4197,7 @@ PP(pp_system) { Pid_t childpid; int pp[2]; + I32 did_pipes = 0; if (PerlProc_pipe(pp) >= 0) did_pipes = 1; @@ -4272,14 +4279,14 @@ PP(pp_system) result = 0; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; -# if defined(WIN32) || defined(OS2) +# if defined(WIN32) || defined(OS2) || defined(SYMBIAN) value = (I32)do_aspawn(really, MARK, SP); # else value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); # endif } else if (SP - MARK != 1) { -# if defined(WIN32) || defined(OS2) +# if defined(WIN32) || defined(OS2) || defined(SYMBIAN) value = (I32)do_aspawn(Nullsv, MARK, SP); # else value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP); @@ -4524,9 +4531,11 @@ PP(pp_gmtime) dSP; Time_t when; const struct tm *tmbuf; - static const char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; - static const char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun", - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; + static const char * const dayname[] = + {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; + static const char * const monname[] = + {"Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; if (MAXARG < 1) (void)time(&when); diff --git a/proto.h b/proto.h index 0866d7d..c26f87b 100644 --- a/proto.h +++ b/proto.h @@ -160,7 +160,7 @@ PERL_CALLCONV void Perl_do_chop(pTHX_ SV* asv, SV* sv); PERL_CALLCONV bool Perl_do_close(pTHX_ GV* gv, bool not_implicit); PERL_CALLCONV bool Perl_do_eof(pTHX_ GV* gv); PERL_CALLCONV bool Perl_do_exec(pTHX_ char* cmd); -#if defined(WIN32) +#if defined(WIN32) || defined(SYMBIAN) PERL_CALLCONV int Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp); PERL_CALLCONV int Perl_do_spawn(pTHX_ char* cmd); PERL_CALLCONV int Perl_do_spawn_nowait(pTHX_ char* cmd); @@ -228,7 +228,7 @@ PERL_CALLCONV GV* Perl_gv_IOadd(pTHX_ GV* gv); PERL_CALLCONV GV* Perl_gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN len, I32 method); PERL_CALLCONV void Perl_gv_check(pTHX_ HV* stash); PERL_CALLCONV void Perl_gv_efullname(pTHX_ SV* sv, const GV* gv); -/* PERL_CALLCONV void gv_efullname3(pTHX_ SV* sv, const GV* gv, const char* prefix); */ +/* PERL_CALLCONV void Perl_gv_efullname3(pTHX_ SV* sv, const GV* gv, const char* prefix); */ PERL_CALLCONV void Perl_gv_efullname4(pTHX_ SV* sv, const GV* gv, const char* prefix, bool keepmain); PERL_CALLCONV GV* Perl_gv_fetchfile(pTHX_ const char* name); PERL_CALLCONV GV* Perl_gv_fetchmeth(pTHX_ HV* stash, const char* name, STRLEN len, I32 level); @@ -237,7 +237,7 @@ PERL_CALLCONV GV* Perl_gv_fetchmethod(pTHX_ HV* stash, const char* name); PERL_CALLCONV GV* Perl_gv_fetchmethod_autoload(pTHX_ HV* stash, const char* name, I32 autoload); PERL_CALLCONV GV* Perl_gv_fetchpv(pTHX_ const char* name, I32 add, I32 sv_type); PERL_CALLCONV void Perl_gv_fullname(pTHX_ SV* sv, const GV* gv); -/* PERL_CALLCONV void gv_fullname3(pTHX_ SV* sv, const GV* gv, const char* prefix); */ +/* PERL_CALLCONV void Perl_gv_fullname3(pTHX_ SV* sv, const GV* gv, const char* prefix); */ PERL_CALLCONV void Perl_gv_fullname4(pTHX_ SV* sv, const GV* gv, const char* prefix, bool keepmain); PERL_CALLCONV void Perl_gv_init(pTHX_ GV* gv, HV* stash, const char* name, STRLEN len, int multi); PERL_CALLCONV HV* Perl_gv_stashpv(pTHX_ const char* name, I32 create); @@ -1237,8 +1237,10 @@ STATIC SV* S_isa_lookup(pTHX_ HV *stash, const char *name, HV *name_stash, int l #endif #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) +#if defined(USE_LOCALE_NUMERIC) || defined(USE_LOCALE_COLLATE) STATIC char* S_stdize_locale(pTHX_ char* locs); #endif +#endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) STATIC COP* S_closest_cop(pTHX_ COP *cop, OP *o); @@ -1421,4 +1423,7 @@ PERL_CALLCONV bool Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags); PERL_CALLCONV char* Perl_savesvpv(pTHX_ SV* sv); +PERL_CALLCONV struct perl_vars* Perl_init_global_struct(pTHX); +PERL_CALLCONV void Perl_free_global_struct(pTHX_ struct perl_vars*); + END_EXTERN_C diff --git a/reentr.pl b/reentr.pl index c100115..53a76e2 100644 --- a/reentr.pl +++ b/reentr.pl @@ -798,7 +798,7 @@ Perl_reentrant_free(pTHX) { void* Perl_reentrant_retry(const char *f, ...) { - dTHX; + dVAR; dTHX; void *retptr = NULL; #ifdef USE_REENTRANT_API # if defined(USE_HOSTENT_BUFFER) || defined(USE_GRENT_BUFFER) || defined(USE_NETENT_BUFFER) || defined(USE_PWENT_BUFFER) || defined(USE_PROTOENT_BUFFER) || defined(USE_SERVENT_BUFFER) diff --git a/regcomp.c b/regcomp.c index ab1c218..d4640ea 100644 --- a/regcomp.c +++ b/regcomp.c @@ -206,8 +206,8 @@ typedef struct scan_data_t { * Forward declarations for pregcomp()'s friends. */ -static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0}; +static const scan_data_t zero_scan_data = + { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL) #define SF_BEFORE_SEOL 0x1 @@ -834,6 +834,7 @@ and would end up looking like: STATIC I32 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 flags) { + dVAR; /* first pass, loop through and scan words */ reg_trie_data *trie; regnode *cur; @@ -3227,6 +3228,7 @@ STATIC regnode * S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp) /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */ { + dVAR; register regnode *ret; /* Will be the head of the group. */ register regnode *br; register regnode *lastbr; @@ -6123,6 +6125,7 @@ Perl_re_intuit_string(pTHX_ regexp *prog) void Perl_pregfree(pTHX_ struct regexp *r) { + dVAR; #ifdef DEBUGGING SV *dsv = PERL_DEBUG_PAD_ZERO(0); SV *re_debug_flags=get_sv(RE_DEBUG_FLAGS,0); diff --git a/regexec.c b/regexec.c index 17ee6af..8947cce 100644 --- a/regexec.c +++ b/regexec.c @@ -965,6 +965,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, STATIC char * S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, I32 norun) { + dVAR; I32 doevery = (prog->reganch & ROPT_SKIP) == 0; char *m; STRLEN ln; @@ -2380,6 +2381,7 @@ typedef union re_unwind_t { STATIC I32 /* 0 failure, 1 success */ S_regmatch(pTHX_ regnode *prog) { + dVAR; register regnode *scan; /* Current node. */ regnode *next; /* Next node. */ regnode *inner; /* Next node in internal branch. */ @@ -4359,6 +4361,7 @@ do_no: STATIC I32 S_regrepeat(pTHX_ regnode *p, I32 max) { + dVAR; register char *scan; register I32 c; register char *loceol = PL_regeol; @@ -4706,6 +4709,7 @@ Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** listsvp, SV STATIC bool S_reginclass(pTHX_ register regnode *n, register U8* p, STRLEN* lenp, register bool do_utf8) { + dVAR; char flags = ANYOF_FLAGS(n); bool match = FALSE; UV c = *p; diff --git a/scope.h b/scope.h index 73b94cb..2fa7f60 100644 --- a/scope.h +++ b/scope.h @@ -331,3 +331,4 @@ typedef struct jmpenv JMPENV; #define CATCH_GET (PL_top_env->je_mustcatch) #define CATCH_SET(v) (PL_top_env->je_mustcatch = (v)) + diff --git a/sv.c b/sv.c index 7bfd7a5..ab9603f 100644 --- a/sv.c +++ b/sv.c @@ -645,6 +645,7 @@ Perl_sv_free_arenas(pTHX) STATIC SV* S_find_hash_subscript(pTHX_ HV *hv, SV* val) { + dVAR; register HE **array; register HE *entry; I32 i; @@ -790,6 +791,7 @@ PL_comppad/PL_curpad points to the currently executing pad. STATIC SV * S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) { + dVAR; SV *sv; AV *av; SV **svp; @@ -3666,6 +3668,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) return SvPVX(tsv); } else { + dVAR; STRLEN len; const char *t; @@ -5506,7 +5509,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam } /* Rest of work is done else where */ - mg = sv_magicext(sv,obj,how,vtable,name,namlen); + mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen); switch (how) { case PERL_MAGIC_taint: @@ -5826,6 +5829,7 @@ instead. void Perl_sv_clear(pTHX_ register SV *sv) { + dVAR; HV* stash; assert(sv); assert(SvREFCNT(sv) == 0); @@ -6075,6 +6079,7 @@ Normally called via a wrapper macro C. void Perl_sv_free(pTHX_ SV *sv) { + dVAR; if (!sv) return; if (SvREFCNT(sv) == 0) { @@ -6103,6 +6108,7 @@ Perl_sv_free(pTHX_ SV *sv) void Perl_sv_free2(pTHX_ SV *sv) { + dVAR; #ifdef DEBUGGING if (SvTEMP(sv)) { if (ckWARN_d(WARN_DEBUGGING)) @@ -6213,7 +6219,7 @@ S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offse if (SvMAGICAL(sv) && !SvREADONLY(sv)) { if (!*mgp) - *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); + *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0); assert(*mgp); if ((*mgp)->mg_ptr) @@ -7137,17 +7143,7 @@ thats_really_all_folks: else { /*The big, slow, and stupid way. */ - - /* Any stack-challenged places. */ -#if defined(EPOC) - /* EPOC: need to work around SDK features. * - * On WINS: MS VC5 generates calls to _chkstk, * - * if a "large" stack frame is allocated. * - * gcc on MARM does not generate calls like these. */ -# define USEHEAPINSTEADOFSTACK -#endif - -#ifdef USEHEAPINSTEADOFSTACK +#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ STDCHAR *buf = 0; New(0, buf, 8192, STDCHAR); assert(buf); @@ -7202,7 +7198,7 @@ screamer2: goto screamer2; } -#ifdef USEHEAPINSTEADOFSTACK +#ifdef USE_HEAP_INSTEAD_OF_STACK Safefree(buf); #endif } @@ -7555,6 +7551,7 @@ and C. SV * Perl_sv_2mortal(pTHX_ register SV *sv) { + dVAR; if (!sv) return sv; if (SvREADONLY(sv) && SvIMMORTAL(sv)) @@ -7832,6 +7829,7 @@ Note that the perl-level function is vaguely deprecated. void Perl_sv_reset(pTHX_ register const char *s, HV *stash) { + dVAR; register HE *entry; register GV *gv; register SV *sv; @@ -7964,6 +7962,7 @@ possible to set C<*st> and C<*gvp> to the stash and GV associated with it. CV * Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) { + dVAR; GV *gv = Nullgv; CV *cv = Nullcv; @@ -9116,7 +9115,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV char *patend; STRLEN origlen; I32 svix = 0; - static char nullstr[] = "(null)"; + static const char nullstr[] = "(null)"; SV *argsv = Nullsv; bool has_utf8; /* has the result utf8? */ bool pat_utf8; /* the pattern is in utf8? */ @@ -9519,7 +9518,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif elen = strlen(eptr); else { - eptr = nullstr; + eptr = (char *)nullstr; elen = sizeof nullstr - 1; } } @@ -10142,6 +10141,7 @@ ptr_table_* functions. REGEXP * Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) { + dVAR; REGEXP *ret; int i, len, npar; struct reg_substr_datum *s; @@ -10534,10 +10534,6 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) Safefree(tbl); } -#ifdef DEBUGGING -char *PL_watch_pvx; -#endif - /* attempt to make everything in the typeglob readonly */ STATIC SV * @@ -10655,6 +10651,7 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) SV * Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) { + dVAR; SV *dstr; if (!sstr || SvTYPE(sstr) == SVTYPEMASK) @@ -11504,6 +11501,7 @@ perl_clone_host(PerlInterpreter* proto_perl, UV flags); PerlInterpreter * perl_clone(PerlInterpreter *proto_perl, UV flags) { + dVAR; #ifdef PERL_IMPLICIT_SYS /* perlhost.h so we need to call into it @@ -12322,6 +12320,7 @@ The PV of the sv is returned. char * Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) { + dVAR; if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { SV *uni; STRLEN len; @@ -12383,6 +12382,7 @@ bool Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, SV *ssv, int *offset, char *tstr, int tlen) { + dVAR; bool ret = FALSE; if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { SV *offsv; diff --git a/symbian/PerlApp.cpp b/symbian/PerlApp.cpp new file mode 100644 index 0000000..319a591 --- /dev/null +++ b/symbian/PerlApp.cpp @@ -0,0 +1,549 @@ +/* Copyright (c) 2004-2005 Nokia. All rights reserved. */ + +/* The PerlApp application is licensed under the same terms as Perl itself. */ + +#include "PerlApp.h" + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include + +#ifndef __SERIES60_1X__ +#include +#endif + +#include + +#include "PerlApp.hrh" +#include "PerlApp.rsg" + +#include "patchlevel.h" +#include "PerlBase.h" + +const TUid KPerlAppUid = { 0x102015F6 }; + +// This is like the Symbian _LIT() but without the embedded L prefix, +// which enables using #defined constants (which need to carry their +// own L prefix). +#ifndef _LIT_NO_L +#define _LIT_NO_L(n, s) static const TLitC n={sizeof(s)/2-1,s} +#endif // #ifndef _LIT_NO_L + +_LIT(KAppName, "PerlApp"); +_LIT_NO_L(KFlavor, PERL_SYMBIANSDK_FLAVOR); +_LIT(KAboutFormat, + "Perl %d.%d.%d, Symbian port %d.%d.%d, built for %S SDK %d.%d"); +_LIT(KCopyrightFormat, + "Copyright 1987-2005 Larry Wall and others, Symbian port Copyright Nokia 2004-2005"); +_LIT(KInboxPrefix, "\\System\\Mail\\"); +_LIT(KScriptPrefix, "\\Perl\\"); + +_LIT8(KModulePrefix, SITELIB); // SITELIB from Perl config.h + +typedef TBuf<256> TMessageBuffer; +typedef TBuf8<256> TPeekBuffer; +typedef TBuf8<256> TFileName8; + +// Usage: DEBUG_PRINTF((_L("%S"), &aStr)) +#if 1 +#define DEBUG_PRINTF(s) {TMessageBuffer message; message.Format s; YesNoDialogL(message);} +#endif + +TUid CPerlAppApplication::AppDllUid() const +{ + return KPerlAppUid; +} + +enum TPerlAppPanic +{ + EPerlAppCommandUnknown = 1 +}; + +void Panic(TPerlAppPanic aReason) +{ + User::Panic(KAppName, aReason); +} + +void CPerlAppUi::ConstructL() +{ + BaseConstructL(); + iAppView = CPerlAppView::NewL(ClientRect()); + AddToStackL(iAppView); + iFs = NULL; + CEikonEnv::Static()->DisableExitChecks(ETrue); // Symbian FAQ-0577. +} + +CPerlAppUi::~CPerlAppUi() +{ + if (iAppView) { + iEikonEnv->RemoveFromStack(iAppView); + delete iAppView; + iAppView = NULL; + } + if (iFs) { + delete iFs; + iFs = NULL; + } + if (iDoorObserver) // Otherwise the embedding application waits forever. + iDoorObserver->NotifyExit(MApaEmbeddedDocObserver::EEmpty); +} + +static TBool DlgOk(CAknNoteDialog* dlg) +{ + return dlg && dlg->RunDlgLD() == EAknSoftkeyOk; +} + +static TBool OkCancelDialogL(TDesC& aMessage) +{ + CAknNoteDialog* dlg = + new (ELeave) CAknNoteDialog(CAknNoteDialog::EConfirmationTone); + dlg->PrepareLC(R_OK_CANCEL_DIALOG); + dlg->SetTextL(aMessage); + return DlgOk(dlg); +} + +static TBool YesNoDialogL(TDesC& aMessage) +{ + CAknNoteDialog* dlg = + new (ELeave) CAknNoteDialog(CAknNoteDialog::EConfirmationTone); + dlg->PrepareLC(R_YES_NO_DIALOG); + dlg->SetTextL(aMessage); + return DlgOk(dlg); +} + +static TInt InformationNoteL(TDesC& aMessage) +{ + CAknInformationNote* note = new (ELeave) CAknInformationNote; + return note->ExecuteLD(aMessage); +} + +static TInt ConfirmationNoteL(TDesC& aMessage) +{ + CAknConfirmationNote* note = new (ELeave) CAknConfirmationNote; + return note->ExecuteLD(aMessage); +} + +static TInt WarningNoteL(TDesC& aMessage) +{ + CAknWarningNote* note = new (ELeave) CAknWarningNote; + return note->ExecuteLD(aMessage); +} + +static TInt TextQueryDialogL(const TDesC& aPrompt, TDes& aData, const TInt aMaxLength) +{ + CAknTextQueryDialog* dlg = + new (ELeave) CAknTextQueryDialog(aData); + dlg->SetPromptL(aPrompt); + dlg->SetMaxLength(aMaxLength); + return dlg->ExecuteLD(R_TEXT_QUERY_DIALOG); +} + +// The isXXX() come from the Perl headers. +#define FILENAME_IS_ABSOLUTE(n) \ + (isALPHA(((n)[0])) && ((n)[1]) == ':' && ((n)[2]) == '\\') + +static TBool IsInPerl(TFileName aFileName) +{ + TInt offset = aFileName.FindF(KScriptPrefix); + return ((offset == 0 && // \foo + aFileName[0] == '\\') + || + (offset == 2 && // x:\foo + FILENAME_IS_ABSOLUTE(aFileName))); +} + +static TBool IsInInbox(TFileName aFileName) +{ + TInt offset = aFileName.FindF(KInboxPrefix); + return ((offset == 0 && // \foo + aFileName[0] == '\\') + || + (offset == 2 && // x:\foo + FILENAME_IS_ABSOLUTE(aFileName))); +} + +static TBool IsPerlModule(TParsePtrC aParsed) +{ + return aParsed.Ext().CompareF(_L(".pm")) == 0; +} + +static TBool IsPerlScript(TParsePtrC aParsed) +{ + return aParsed.Ext().CompareF(_L(".pl")) == 0; +} + +static void CopyFromInboxL(RFs aFs, const TFileName& aSrc, const TFileName& aDst) +{ + TBool proceed = ETrue; + TMessageBuffer message; + + message.Format(_L("%S is untrusted. Install only if you trust provider."), &aDst); + if (OkCancelDialogL(message)) { + message.Format(_L("Install as %S?"), &aDst); + if (OkCancelDialogL(message)) { + if (BaflUtils::FileExists(aFs, aDst)) { + message.Format(_L("Replace old %S?"), &aDst); + if (!OkCancelDialogL(message)) + proceed = EFalse; + } + if (proceed) { + // Create directory? + TInt err = BaflUtils::CopyFile(aFs, aSrc, aDst); + if (err == KErrNone) { + message.Format(_L("Installed %S"), &aDst); + ConfirmationNoteL(message); + } + else { + message.Format(_L("Failure %d installing %S"), err, &aDst); + WarningNoteL(message); + } + } + } + } +} + +static TBool FindPerlPackageName(TPeekBuffer aPeekBuffer, TInt aOff, TFileName& aFn) +{ + aFn.SetMax(); + TInt m = aFn.MaxLength(); + TInt n = aPeekBuffer.Length(); + TInt i = 0; + TInt j = aOff; + + aFn.SetMax(); + // The following is a little regular expression + // engine that matches Perl package names. + if (j < n && isSPACE(aPeekBuffer[j])) { + while (j < n && isSPACE(aPeekBuffer[j])) j++; + if (j < n && isALPHA(aPeekBuffer[j])) { + while (j < n && isALNUM(aPeekBuffer[j])) { + while (j < n && + isALNUM(aPeekBuffer[j]) && + i < m) + aFn[i++] = aPeekBuffer[j++]; + if (j + 1 < n && + aPeekBuffer[j ] == ':' && + aPeekBuffer[j + 1] == ':' && + i < m) { + aFn[i++] = '\\'; + j += 2; + if (j < n && + isALPHA(aPeekBuffer[j])) { + while (j < n && + isALNUM(aPeekBuffer[j]) && + i < m) + aFn[i++] = aPeekBuffer[j++]; + } + } + } + while (j < n && isSPACE(aPeekBuffer[j])) j++; + if (j < n && aPeekBuffer[j] == ';' && i + 3 < m) { + aFn.SetLength(i); + aFn.Append(_L(".pm")); + return ETrue; + } + } + } + return EFalse; +} + +static void GuessPerlModule(TFileName& aGuess, TPeekBuffer aPeekBuffer, TParse aDrive) +{ + TInt offset = aPeekBuffer.Find(_L8("package")); + if (offset != KErrNotFound) { + const TInt KPackageLen = 7; + TFileName q; + + if (!FindPerlPackageName(aPeekBuffer, offset + KPackageLen, q)) + return; + + TFileName8 p; + p.Copy(aDrive.Drive()); + p.Append(KModulePrefix); + + aGuess.SetMax(); + if (p.Length() + 1 + q.Length() < aGuess.MaxLength()) { + TInt i = 0, j; + + for (j = 0; j < p.Length(); j++) + aGuess[i++] = p[j]; + aGuess[i++] = '\\'; + for (j = 0; j < q.Length(); j++) + aGuess[i++] = q[j]; + aGuess.SetLength(i); + } + else + aGuess.SetLength(0); + } +} + +static TBool LooksLikePerlL(TPeekBuffer aPeekBuffer) +{ + return aPeekBuffer.Left(2).Compare(_L8("#!")) == 0 && + aPeekBuffer.Find(_L8("perl")) != KErrNotFound; +} + +static TBool InstallStuffL(const TFileName &aSrc, TParse aDrive, TParse aFile, TPeekBuffer aPeekBuffer, RFs aFs) +{ + TFileName aDst; + TPtrC drive = aDrive.Drive(); + TPtrC namext = aFile.NameAndExt(); + + aDst.Format(_L("%S%S%S"), &drive, &KScriptPrefix, &namext); + if (!IsPerlScript(aDst) && !LooksLikePerlL(aPeekBuffer)) { + aDst.SetLength(0); + if (IsPerlModule(aDst)) + GuessPerlModule(aDst, aPeekBuffer, aDrive); + } + if (aDst.Length() > 0) { + CopyFromInboxL(aFs, aSrc, aDst); + return ETrue; + } + + return EFalse; +} + +static void DoRunScriptL(TFileName aScriptName) +{ + CPerlBase* perl = CPerlBase::NewInterpreterLC(); + TRAPD(error, perl->RunScriptL(aScriptName)); + if (error != KErrNone) { + TMessageBuffer message; + message.Format(_L("Error %d"), error); + YesNoDialogL(message); + } + CleanupStack::PopAndDestroy(perl); +} + +static TBool RunStuffL(const TFileName& aScriptName, TPeekBuffer aPeekBuffer) +{ + TBool isModule = EFalse; + + if (IsInPerl(aScriptName) && + (IsPerlScript(aScriptName) || + (isModule = IsPerlModule(aScriptName)) || + LooksLikePerlL(aPeekBuffer))) { + TMessageBuffer message; + + if (isModule) + message.Format(_L("Really run module %S?"), &aScriptName); + else + message.Format(_L("Run %S?"), &aScriptName); + if (YesNoDialogL(message)) + DoRunScriptL(aScriptName); + + return ETrue; + } + + return EFalse; +} + +void CPerlAppUi::InstallOrRunL(const TFileName& aFileName) +{ + TParse aFile; + TParse aDrive; + TMessageBuffer message; + + aFile.Set(aFileName, NULL, NULL); + if (FILENAME_IS_ABSOLUTE(aFileName)) { + aDrive.Set(aFileName, NULL, NULL); + } else { + TFileName appName = + CEikonEnv::Static()->EikAppUi()->Application()->AppFullName(); + aDrive.Set(appName, NULL, NULL); + } + if (!iFs) + iFs = &CEikonEnv::Static()->FsSession(); + RFile f; + TInt err = f.Open(*iFs, aFileName, EFileRead); + if (err == KErrNone) { + TPeekBuffer aPeekBuffer; + err = f.Read(aPeekBuffer); + f.Close(); // Release quickly. + if (err == KErrNone) { + if (!(IsInInbox(aFileName) ? + InstallStuffL(aFileName, aDrive, aFile, aPeekBuffer, *iFs) : + RunStuffL(aFileName, aPeekBuffer))) { + message.Format(_L("Failed for file %S"), &aFileName); + WarningNoteL(message); + } + } else { + message.Format(_L("Error %d reading %S"), err, &aFileName); + WarningNoteL(message); + } + } else { + message.Format(_L("Error %d opening %S"), err, &aFileName); + WarningNoteL(message); + } + if (iDoorObserver) + delete CEikonEnv::Static()->EikAppUi(); + else + Exit(); +} + +void CPerlAppUi::OpenFileL(const TDesC& aFileName) +{ + InstallOrRunL(aFileName); + return; +} + +TBool CPerlAppUi::ProcessCommandParametersL(TApaCommand aCommand, TFileName& /* aDocumentName */, const TDesC8& /* aTail */) +{ + return aCommand == EApaCommandOpen ? ETrue : EFalse; +} + +void CPerlAppUi::SetFs(const RFs& aFs) +{ + iFs = (RFs*) &aFs; +} + +void CPerlAppUi::HandleCommandL(TInt aCommand) +{ + TMessageBuffer message; + + switch(aCommand) + { + case EEikCmdExit: + case EAknSoftkeyExit: + Exit(); + break; + case EPerlAppCommandAbout: + { + message.Format(KAboutFormat, + PERL_REVISION, + PERL_VERSION, + PERL_SUBVERSION, + PERL_SYMBIANPORT_MAJOR, + PERL_SYMBIANPORT_MINOR, + PERL_SYMBIANPORT_PATCH, + &KFlavor, + PERL_SYMBIANSDK_MAJOR, + PERL_SYMBIANSDK_MINOR + ); + InformationNoteL(message); + } + break; + case EPerlAppCommandTime: + { + CPerlBase* perl = CPerlBase::NewInterpreterLC(); + const char *const argv[] = + { "perl", "-le", + "print 'Running in ', $^O, \"\\n\", scalar localtime" }; + perl->ParseAndRun(sizeof(argv)/sizeof(char*), (char **)argv, 0); + CleanupStack::PopAndDestroy(perl); + } + break; + case EPerlAppCommandRunFile: + { + InformationNoteL(message); + TFileName aScriptUtf16; + if (AknCommonDialogs::RunSelectDlgLD(aScriptUtf16, + R_MEMORY_SELECTION_DIALOG)) + DoRunScriptL(aScriptUtf16); + } + break; + case EPerlAppCommandOneLiner: + { + _LIT(prompt, "Oneliner:"); + if (TextQueryDialogL(prompt, iOneLiner, KPerlAppOneLinerSize)) { + const TUint KPerlAppUtf8Multi = 3; + TBuf8 utf8; + + CnvUtfConverter::ConvertFromUnicodeToUtf8(utf8, iOneLiner); + CPerlBase* perl = CPerlBase::NewInterpreterLC(); + int argc = 3; + char **argv = (char**) malloc(argc * sizeof(char *)); + User::LeaveIfNull(argv); + + TCleanupItem argvCleanupItem = TCleanupItem(free, argv); + CleanupStack::PushL(argvCleanupItem); + argv[0] = (char *) "perl"; + argv[1] = (char *) "-le"; + argv[2] = (char *) utf8.PtrZ(); + perl->ParseAndRun(argc, argv); + CleanupStack::PopAndDestroy(2, perl); + } + } + break; + case EPerlAppCommandCopyright: + { + message.Format(KCopyrightFormat); + InformationNoteL(message); + } + break; + + default: + Panic(EPerlAppCommandUnknown); + break; + } +} + +CPerlAppView* CPerlAppView::NewL(const TRect& aRect) +{ + CPerlAppView* self = CPerlAppView::NewLC(aRect); + CleanupStack::Pop(self); + return self; +} + +CPerlAppView* CPerlAppView::NewLC(const TRect& aRect) +{ + CPerlAppView* self = new (ELeave) CPerlAppView; + CleanupStack::PushL(self); + self->ConstructL(aRect); + return self; +} + +void CPerlAppView::ConstructL(const TRect& aRect) +{ + CreateWindowL(); + SetRect(aRect); + ActivateL(); +} + +void CPerlAppView::Draw(const TRect& /*aRect*/) const +{ + CWindowGc& gc = SystemGc(); + TRect rect = Rect(); + gc.Clear(rect); +} + +CApaDocument* CPerlAppApplication::CreateDocumentL() +{ + CPerlAppDocument* document = new (ELeave) CPerlAppDocument(*this); + return document; +} + +CEikAppUi* CPerlAppDocument::CreateAppUiL() +{ + CPerlAppUi* appui = new (ELeave) CPerlAppUi(); + return appui; +} + +CFileStore* CPerlAppDocument::OpenFileL(TBool /* aDoOpen */, const TDesC& aFileName, RFs& aFs) +{ + CPerlAppUi* appui = + STATIC_CAST(CPerlAppUi*, CEikonEnv::Static()->EikAppUi()); + appui->SetFs(aFs); + appui->OpenFileL(aFileName); + return NULL; +} + +EXPORT_C CApaApplication* NewApplication() +{ + return new CPerlAppApplication; +} + +GLDEF_C TInt E32Dll(TDllReason /*aReason*/) +{ + return KErrNone; +} + diff --git a/symbian/PerlApp.h b/symbian/PerlApp.h new file mode 100644 index 0000000..37a02f2 --- /dev/null +++ b/symbian/PerlApp.h @@ -0,0 +1,60 @@ +/* Copyright (c) 2004-2005 Nokia. All rights reserved. */ + +/* The PerlApp application is licensed under the same terms as Perl itself. */ + +#ifndef __PerlApp_h__ +#define __PerlApp_h__ + +#include +#include +#include +#include +#include + +class CPerlAppDocument : public CAknDocument +{ + public: + CPerlAppDocument(CEikApplication& aApp):CAknDocument(aApp) {;} + CFileStore* OpenFileL(TBool aDoOpen, const TDesC& aFilename, RFs& aFs); + private: // from CEikDocument + CEikAppUi* CreateAppUiL(); +}; + +class CPerlAppApplication : public CAknApplication +{ + private: + CApaDocument* CreateDocumentL(); + TUid AppDllUid() const; +}; + +const TUint KPerlAppOneLinerSize = 80; + +class CPerlAppView; + +class CPerlAppUi : public CAknAppUi +{ + public: + void ConstructL(); + ~CPerlAppUi(); + void HandleCommandL(TInt aCommand); + void OpenFileL(const TDesC& aFileName); + TBool ProcessCommandParametersL(TApaCommand aCommand, TFileName& aDocumentName, const TDesC8& aTail); + void InstallOrRunL(const TFileName& aFileName); + void SetFs(const RFs& aFs); + private: + CPerlAppView* iAppView; + RFs* iFs; + TBuf iOneLiner; +}; + +class CPerlAppView : public CCoeControl +{ + public: + static CPerlAppView* NewL(const TRect& aRect); + static CPerlAppView* NewLC(const TRect& aRect); + void Draw(const TRect& aRect) const; + private: + void ConstructL(const TRect& aRect); +}; + +#endif // __PerlApp_h__ diff --git a/symbian/PerlApp.hrh b/symbian/PerlApp.hrh new file mode 100644 index 0000000..3b0f23d --- /dev/null +++ b/symbian/PerlApp.hrh @@ -0,0 +1,17 @@ +/* Copyright (c) 2004-2005 Nokia. All rights reserved. */ + +/* The PerlApp application is licensed under the same terms as Perl itself. */ + +#ifndef __PerlApp_HRH__ +#define __PerlApp_HRH__ + +enum TPerlIds +{ + EPerlAppCommandAbout = 1024, // start value must not be 0 + EPerlAppCommandTime = 1025, + EPerlAppCommandRunFile = 1026, + EPerlAppCommandOneLiner = 1027, + EPerlAppCommandCopyright = 1028 // no comma here +}; + +#endif // __PerlApp_HRH__ diff --git a/symbian/PerlApp.rss b/symbian/PerlApp.rss new file mode 100644 index 0000000..c352c52 --- /dev/null +++ b/symbian/PerlApp.rss @@ -0,0 +1,141 @@ +/* Copyright (c) 2004-2005 Nokia. All rights reserved. */ + +/* The PerlApp application is licensed under the same terms as Perl itself. */ + +NAME PERL + +#include +#include +#include + +#include "PerlApp.hrh" + +RESOURCE RSS_SIGNATURE +{ +} + +RESOURCE TBUF r_default_document_name +{ + buf = ""; +} + +RESOURCE EIK_APP_INFO +{ + menubar = r_Perl_menubar; + cba = R_AVKON_SOFTKEYS_OPTIONS_EXIT; +} + + +RESOURCE MENU_BAR r_Perl_menubar +{ + titles = { + MENU_TITLE + { + menu_pane = r_Perl_menu; + } + }; +} + + +RESOURCE MENU_PANE r_Perl_menu +{ + items = { + MENU_ITEM { + command = EPerlAppCommandAbout; + txt = "About"; + }, + MENU_ITEM { + command = EPerlAppCommandTime; + txt = "Time"; + }, + MENU_ITEM { + command = EPerlAppCommandRunFile; + txt = "Run"; + }, + MENU_ITEM { + command = EPerlAppCommandOneLiner; + txt = "Oneliner"; + }, + MENU_ITEM { + command = EPerlAppCommandCopyright; + txt = "Copyright"; + } + }; +} + +RESOURCE DIALOG r_ok_cancel_dialog +{ + flags = EEikDialogFlagWait | EEikDialogFlagCbaButtons; + buttons = R_AVKON_SOFTKEYS_OK_CANCEL; + items = { + DLG_LINE + { + type = EAknCtNote; + id = EGeneralNote; + control = AVKON_NOTE + { + layout = EGeneralLayout; + }; + } + }; +} + +RESOURCE DIALOG r_yes_no_dialog +{ + flags = EEikDialogFlagWait | EEikDialogFlagCbaButtons; + buttons = R_AVKON_SOFTKEYS_YES_NO; + items = { + DLG_LINE + { + type = EAknCtNote; + id = EGeneralNote; + control = AVKON_NOTE + { + layout = EGeneralLayout; + }; + } + }; +} + +RESOURCE DIALOG r_text_query_dialog +{ + flags = EGeneralQueryFlags; + buttons = R_AVKON_SOFTKEYS_OK_CANCEL; + items = { + DLG_LINE + { + type = EAknCtQuery; + id = EGeneralQuery; + control = AVKON_DATA_QUERY + { + layout = EDataLayout; + control = EDWIN {}; + }; + } + }; +} + +RESOURCE AVKON_LIST_QUERY r_list_query_dialog +{ + flags = EGeneralQueryFlags; + softkeys = R_AVKON_SOFTKEYS_OK_CANCEL; + items = { + DLG_LINE + { + type = EAknCtListQueryControl; + id = EListQueryControl; + control = AVKON_LIST_QUERY_CONTROL + { + listtype = EAknCtSinglePopupMenuListBox; + }; + } + }; +} + +#include +#include + +RESOURCE MEMORYSELECTIONDIALOG r_memory_selection_dialog +{ +} + diff --git a/symbian/PerlAppAif.rss b/symbian/PerlAppAif.rss new file mode 100644 index 0000000..fa4d42b --- /dev/null +++ b/symbian/PerlAppAif.rss @@ -0,0 +1,21 @@ +/* Copyright (c) 2004-2005 Nokia. All rights reserved. */ + +/* The PerlApp application is licensed under the same terms as Perl itself. */ + +#include + +RESOURCE AIF_DATA +{ + app_uid = 0x102015F6; + embeddability = KAppEmbeddable; + hidden = KAppNotHidden; + launch = KAppLaunchInForeground; + newfile = KAppDoesNotSupportNewFile; + datatype_list = { + DATATYPE + { + priority = EDataTypePriorityNormal; + type = "x-application/x-perl"; + } + }; + } diff --git a/symbian/PerlBase.cpp b/symbian/PerlBase.cpp new file mode 100644 index 0000000..31fe012 --- /dev/null +++ b/symbian/PerlBase.cpp @@ -0,0 +1,409 @@ +/* Copyright (c) 2004-2005 Nokia. All rights reserved. */ + +/* The CPerlBase class is licensed under the same terms as Perl itself. */ + +/* See PerlBase.pod for documentation. */ + +#define PERLBASE_CPP + +#include +#include +#include + +#include "PerlBase.h" + +const TUint KPerlConsoleBufferMaxTChars = 0x0200; +const TUint KPerlConsoleNoPos = 0xffff; + +CPerlBase::CPerlBase() +{ +} + +EXPORT_C void CPerlBase::Destruct() +{ + iState = EPerlDestroying; + if (iConsole) { + iConsole->Printf(_L("[Any key to continue]")); + iConsole->Getch(); + } + if (iPerl) { + (void)perl_destruct(iPerl); + perl_free(iPerl); + iPerl = NULL; + PERL_SYS_TERM(); + } + if (iConsole) { + delete iConsole; + iConsole = NULL; + } + if (iConsoleBuffer) { + free(iConsoleBuffer); + iConsoleBuffer = NULL; + } +#ifdef PERL_GLOBAL_STRUCT + if (iVars) { + PerlInterpreter* my_perl = NULL; + free_global_struct(iVars); + iVars = NULL; + } +#endif +} + +CPerlBase::~CPerlBase() +{ + Destruct(); +} + +EXPORT_C CPerlBase* CPerlBase::NewInterpreterL(TBool aCloseStdlib, + void (*aStdioInitFunc)(void*), + void *aStdioInitCookie) +{ + CPerlBase* self = + CPerlBase::NewInterpreterLC(aCloseStdlib, + aStdioInitFunc, + aStdioInitCookie); + CleanupStack::Pop(self); + return self; +} + +EXPORT_C CPerlBase* CPerlBase::NewInterpreterLC(TBool aCloseStdlib, + void (*aStdioInitFunc)(void*), + void *aStdioInitCookie) +{ + CPerlBase* self = new (ELeave) CPerlBase; + CleanupStack::PushL(self); + self->iCloseStdlib = aCloseStdlib; + self->iStdioInitFunc = aStdioInitFunc; + self->iStdioInitCookie = aStdioInitCookie; + self->ConstructL(); + PERL_APPCTX_SET(self); + return self; +} + +static int _console_stdin(void* cookie, char* buf, int n) +{ + return ((CPerlBase*)cookie)->ConsoleRead(0, buf, n); +} + +static int _console_stdout(void* cookie, const char* buf, int n) +{ + return ((CPerlBase*)cookie)->ConsoleWrite(1, buf, n); +} + +static int _console_stderr(void* cookie, const char* buf, int n) +{ + return ((CPerlBase*)cookie)->ConsoleWrite(2, buf, n); +} + +void CPerlBase::StdioRewire(void *arg) { + _REENT->_sf[0]._cookie = (void*)this; + _REENT->_sf[0]._read = &_console_stdin; + _REENT->_sf[0]._write = 0; + _REENT->_sf[0]._seek = 0; + _REENT->_sf[0]._close = 0; + + _REENT->_sf[1]._cookie = (void*)this; + _REENT->_sf[1]._read = 0; + _REENT->_sf[1]._write = &_console_stdout; + _REENT->_sf[1]._seek = 0; + _REENT->_sf[1]._close = 0; + + _REENT->_sf[2]._cookie = (void*)this; + _REENT->_sf[2]._read = 0; + _REENT->_sf[2]._write = &_console_stderr; + _REENT->_sf[2]._seek = 0; + _REENT->_sf[2]._close = 0; +} + +void CPerlBase::ConstructL() +{ + iState = EPerlNone; +#ifdef PERL_GLOBAL_STRUCT + PerlInterpreter *my_perl = 0; + iVars = init_global_struct(); + User::LeaveIfNull(iVars); +#endif + iPerl = perl_alloc(); + User::LeaveIfNull(iPerl); + iState = EPerlAllocated; + perl_construct(iPerl); // returns void + if (!iStdioInitFunc) { + iConsole = + Console::NewL(_L("Perl Console"), + TSize(KConsFullScreen, KConsFullScreen)); + iConsoleBuffer = + (TUint16*)malloc(sizeof(TUint) * + KPerlConsoleBufferMaxTChars); + User::LeaveIfNull(iConsoleBuffer); + iConsoleUsed = 0; +#ifndef USE_PERLIO + iStdioInitFunc = &StdioRewire; +#endif + } + if (iStdioInitFunc) + iStdioInitFunc(iStdioInitCookie); + iReadFunc = NULL; + iWriteFunc = NULL; + iState = EPerlConstructed; +} + +EXPORT_C PerlInterpreter* CPerlBase::GetInterpreter() +{ + return (PerlInterpreter*) iPerl; +} + +#ifdef PERL_MINIPERL +static void boot_DynaLoader(pTHX_ CV* cv) { } +#else +EXTERN_C void boot_DynaLoader(pTHX_ CV* cv); +#endif + +static void xs_init(pTHX) +{ + dXSUB_SYS; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__); +} + +EXPORT_C TInt CPerlBase::RunScriptL(const TDesC& aFileName, + int argc, + char **argv, + char *envp[]) { + TBuf8 scriptUtf8; + TInt error; + error = CnvUtfConverter::ConvertFromUnicodeToUtf8(scriptUtf8, aFileName); + User::LeaveIfError(error); + char *filename = (char*)scriptUtf8.PtrZ(); + struct stat st; + if (stat(filename, &st) == -1) + return KErrNotFound; + if (argc < 2) + return KErrGeneral; /* Anything better? */ + char **Argv = (char**)malloc(argc * sizeof(char*)); + User::LeaveIfNull(Argv); + TCleanupItem ArgvCleanupItem = TCleanupItem(free, Argv); + CleanupStack::PushL(ArgvCleanupItem); + Argv[0] = "perl"; + if (argv && argc > 2) + for (int i = 2; i < argc - 1; i++) + Argv[i] = argv[i]; + Argv[argc - 1] = filename; + error = this->ParseAndRun(argc, Argv, envp); + CleanupStack::PopAndDestroy(Argv); + Argv = 0; + return error == 0 ? KErrNone : KErrGeneral; +} + + +EXPORT_C int CPerlBase::Parse(int argc, char *argv[], char *envp[]) +{ + if (iState == EPerlConstructed) { + const char* const NullArgv[] = { "perl", "-e", "0" }; + if (argc == 0 || argv == 0) { + argc = 3; + argv = (char**) NullArgv; + } + PERL_SYS_INIT(&argc, &argv); + int parsed = perl_parse(iPerl, xs_init, argc, argv, envp); + if (parsed == 0) + iState = EPerlParsed; + return parsed; + } else + return -1; +} + +EXPORT_C void CPerlBase::SetupExit() +{ + if (iState == EPerlParsed) { + diTHX; + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + // PL_perl_destruct level of 2 would be nice but + // it causes "Unbalanced scopes" for some reason. + PL_perl_destruct_level = 1; + } +} + +EXPORT_C int CPerlBase::Run() +{ + if (iState == EPerlParsed) { + SetupExit(); + iState = EPerlRunning; + int ran = perl_run(iPerl); + iState = (ran == 0) ? EPerlSuccess : EPerlFailure; + return ran; + } else + return -1; +} + +EXPORT_C int CPerlBase::ParseAndRun(int argc, char *argv[], char *envp[]) +{ + int parsed = Parse(argc, argv, envp); + int ran = (parsed == 0) ? Run() : -1; + return ran; +} + +int CPerlBase::ConsoleReadLine() +{ + if (!iConsole) + return -EIO; + + TUint currX = KPerlConsoleNoPos; + TUint currY = KPerlConsoleNoPos; + TUint prevX = KPerlConsoleNoPos; + TUint prevY = KPerlConsoleNoPos; + TUint maxX = KPerlConsoleNoPos; + TUint offset = 0; + + for (;;) { + TKeyCode code = iConsole->Getch(); + + if (code == EKeyLineFeed || code == EKeyEnter) { + if (offset < KPerlConsoleBufferMaxTChars) { + iConsoleBuffer[offset++] = '\n'; + iConsole->Printf(_L("\n")); + iConsoleBuffer[offset++] = 0; + } + break; + } + else { + TBool doBackward = EFalse; + TBool doBackspace = EFalse; + + prevX = currX; + prevY = currY; + if (code == EKeyBackspace) { + if (offset > 0) { + iConsoleBuffer[--offset] = 0; + doBackward = ETrue; + doBackspace = ETrue; + } + } + else if (offset < KPerlConsoleBufferMaxTChars) { + TChar ch = TChar(code); + + if (ch.IsPrint()) { + iConsoleBuffer[offset++] = (unsigned short)code; + iConsole->Printf(_L("%c"), code); + } + } + currX = iConsole->WhereX(); + currY = iConsole->WhereY(); + if (maxX == KPerlConsoleNoPos && prevX != KPerlConsoleNoPos && + prevY != KPerlConsoleNoPos && currY == prevY + 1) + maxX = prevX; + if (doBackward) { + if (currX > 0) + iConsole->SetPos(currX - 1); + else if (currY > 0) + iConsole->SetPos(maxX, currY - 1); + if (doBackspace) { + TUint nowX = iConsole->WhereX(); + TUint nowY = iConsole->WhereY(); + iConsole->Printf(_L(" ")); /* scrub */ + iConsole->SetPos(nowX, nowY); + } + } + } + } + + return offset; +} + +int CPerlBase::ConsoleRead(const int fd, char* buf, int n) +{ + if (iReadFunc) + return iReadFunc(fd, buf, n); + + if (!iConsole) { + errno = EIO; + return -1; + } + + if (n < 0) { + errno = EINVAL; + return -1; + } + + if (n == 0) + return 0; + + TBuf8<4 * KPerlConsoleBufferMaxTChars> aBufferUtf8; + TBuf16 aBufferUtf16; + int length = ConsoleReadLine(); + int i; + + iConsoleUsed += length; + + aBufferUtf16.SetLength(length); + for (i = 0; i < length; i++) + aBufferUtf16[i] = iConsoleBuffer[i]; + aBufferUtf8.SetLength(4 * length); + + CnvUtfConverter::ConvertFromUnicodeToUtf8(aBufferUtf8, aBufferUtf16); + + char *pUtf8 = (char*)aBufferUtf8.PtrZ(); + int nUtf8 = aBufferUtf8.Size(); + if (nUtf8 > n) + nUtf8 = n; /* Potential data loss. */ +#ifdef PERL_SYMBIAN_CONSOLE_UTF8 + for (i = 0; i < nUtf8; i++) + buf[i] = pUtf8[i]; +#else + dTHX; + for (i = 0; i < nUtf8; i+= UTF8SKIP(pUtf8 + i)) { + unsigned long u = utf8_to_uvchr((U8*)(pUtf8 + i), 0); + if (u > 0xFF) { + iConsole->Printf(_L("(keycode > 0xFF)\n")); + buf[i] = 0; + return -1; + } + buf[i] = u; + } +#endif + if (nUtf8 < n) + buf[nUtf8] = 0; + return nUtf8; +} + +int CPerlBase::ConsoleWrite(const int fd, const char* buf, int n) +{ + if (iWriteFunc) + return iWriteFunc(fd, buf, n); + + if (!iConsole) { + errno = EIO; + return -1; + } + + if (n < 0) { + errno = EINVAL; + return -1; + } + + if (n == 0) + return 0; + + int wrote = 0; +#ifdef PERL_SYMBIAN_CONSOLE_UTF8 + dTHX; + if (is_utf8_string((U8*)buf, n)) { + for (int i = 0; i < n; i += UTF8SKIP(buf + i)) { + TChar u = utf8_to_uvchr((U8*)(buf + i), 0); + iConsole->Printf(_L("%c"), u); + wrote++; + } + } else { + iConsole->Printf(_L("(malformed utf8: ")); + for (int i = 0; i < n; i++) + iConsole->Printf(_L("%02x "), buf[i]); + iConsole->Printf(_L(")\n")); + } +#else + for (int i = 0; i < n; i++) { + iConsole->Printf(_L("%c"), buf[i]); + } + wrote = n; +#endif + iConsoleUsed += wrote; + return n; +} + diff --git a/symbian/PerlBase.h b/symbian/PerlBase.h new file mode 100644 index 0000000..f6765fb --- /dev/null +++ b/symbian/PerlBase.h @@ -0,0 +1,118 @@ +/* Copyright (c) 2004-2005 Nokia. All rights reserved. */ + +/* The CPerlBase class is licensed under the same terms as Perl itself. */ + +/* See PerlBase.pod for documentation. */ + +#ifndef __PerlBase_h__ +#define __PerlBase_h__ + +#include + +#if !defined(PERL_MINIPERL) && !defined(PERL_PERL) +# ifndef PERL_IMPLICIT_CONTEXT +# define PERL_IMPLICIT_CONTEXT +# endif +# ifndef PERL_MULTIPLICITY +# define PERL_MULTIPLICITY +# endif +# ifndef PERL_GLOBAL_STRUCT +# define PERL_GLOBAL_STRUCT +# endif +# ifndef PERL_GLOBAL_STRUCT_PRIVATE +# define PERL_GLOBAL_STRUCT_PRIVATE +# endif +#endif + +#include "EXTERN.h" +#include "perl.h" + +typedef enum { + EPerlNone, + EPerlAllocated, + EPerlConstructed, + EPerlParsed, + EPerlRunning, + EPerlTerminated, + EPerlPaused, + EPerlSuccess, + EPerlFailure, + EPerlDestroying +} TPerlState; + +class PerlConsole; + +class CPerlBase : public CBase +{ + public: + CPerlBase(); + IMPORT_C virtual ~CPerlBase(); + IMPORT_C static CPerlBase* NewInterpreterL(TBool iCloseStdlib = ETrue, + void (*aStdioInitFunc)(void*) = NULL, + void *aStdioInitCookie = NULL); + IMPORT_C static CPerlBase* NewInterpreterLC(TBool iCloseStdlib = ETrue, + void (*aStdioInitFunc)(void*) = NULL, + void *aStdioInitCookie = NULL); + IMPORT_C TInt RunScriptL(const TDesC& aFileName, int argc = 2, char **argv = NULL, char *envp[] = NULL); + IMPORT_C int Parse(int argc = 0, char *argv[] = NULL, char *envp[] = NULL); + IMPORT_C void SetupExit(); + IMPORT_C int Run(); + IMPORT_C int ParseAndRun(int argc = 0, char *argv[] = 0, char *envp[] = 0); + IMPORT_C void Destruct(); + + IMPORT_C PerlInterpreter* GetInterpreter(); + + // These two really should be private but when not using PERLIO + // certain C callback functions of STDLIB need to be able to call + // these. In general, all the console related functionality is + // intentionally hidden and underdocumented. + int ConsoleRead(const int fd, char* buf, int n); + int ConsoleWrite(const int fd, const char* buf, int n); + + // Having these public does not feel right, but maybe someone needs + // to do creative things with them. + int (*iReadFunc)(const int fd, char *buf, int n); + int (*iWriteFunc)(const int fd, const char *buf, int n); + + protected: + PerlInterpreter* iPerl; +#ifdef PERL_GLOBAL_STRUCT + struct perl_vars* iVars; +#else + void* iAppCtx; +#endif + TPerlState iState; + + private: + + void ConstructL(); + CConsoleBase* iConsole; /* The screen. */ + TUint16* iConsoleBuffer; /* The UTF-16 characters. */ + TUint iConsoleUsed; /* How many in iConsoleBuffer. */ + TBool iCloseStdlib; /* Close STDLIB on exit? */ + + void (*iStdioInitFunc)(void *); + void* iStdioInitCookie; + + int ConsoleReadLine(); + void StdioRewire(void*); +}; + +#define diTHX PerlInterpreter* my_perl = iPerl +#define diVAR struct perl_vars* my_vars = iVars + +#ifdef PERL_GLOBAL_STRUCT +# define PERL_APPCTX_SET(c) ((c)->iVars->Gappctx = (c)) +#else +# define PERL_APPCTX_SET(c) (PL_appctx = (c)) +#endif + +#undef Copy +#undef CopyD /* For symmetry, not for Symbian reasons. */ +#undef New +#define PerlCopy(s,d,n,t) (MEM_WRAP_CHECK(n,t), (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))) +#define PerlCopyD(s,d,n,t) (MEM_WRAP_CHECK(n,t), memcpy((char*)(d),(char*)(s), (n) * sizeof(t))) +#define PerlNew(x,v,n,t) (v = (MEM_WRAP_CHECK(n,t), (t*)safemalloc((MEM_SIZE)((n)*sizeof(t))))) + +#endif /* #ifndef __PerlBase_h__ */ + diff --git a/symbian/PerlBase.pod b/symbian/PerlBase.pod new file mode 100644 index 0000000..265e2d6 --- /dev/null +++ b/symbian/PerlBase.pod @@ -0,0 +1,202 @@ +=head1 NAME + +CPerlBase - a base class encapsulating a Perl interpreter + +=head1 SYNOPSIS + + // in your App.mmp + USERINCLUDE \symbian\perl\x.y.z\include + LIBRARY perlXYZ.lib + + // in your App + #include "PerlBase.h" // includes also EXTERN.h and perl.h + CPerlBase* perl = CPerlBase::NewInterpreterLC(); + ... + delete perl; + +=head1 DESCRIPTION + +CPerlBase is a simple Symbian C++ class that wraps a Perl +interpreter; its creation, use, and destroying. To understand +what this is doing, and how to use the interpreter, a fair knowledge +of L, L, and L is recommended. + +One useful thing CPerlBase does compared with just using the raw +Perl C API is that it redirects the "std streams" (STDOUT et alia) +to a text console implementation which while being very basic +is marginally more usable than the Symbian basic text console. + +=head2 The Basics + +=over 4 + +=item * + +CPerlBase* NewInterpreterL(); + +The constructor that does not keep the object in the Symbian "cleanup stack". +perl_alloc() and perl_construct() are called behind the curtains. + +Accepts the same arguments as NewInterpreterLC(). + +=item * + +CPerlBase* NewInterpreterLC(); + +The constructor that keeps the object in the Symbian "cleanup stack". +perl_alloc() and perl_construct() are called behind the curtains. + +Can have three arguments: + +=over 8 + +=item * + +TBool aCloseStdlib = ETrue + +Should a CPerlBase close the Symbian POSIX STDLIB when closing down. +Good for one-shot script execution, probably less good for longer term +embedded interpreter. + +=item * + +void (*aStdioInitFunc)(void*) = NULL + +If set, called with aStdioInitCookie, and the default console is +not created. You may want to set the iReadFunc() and iWriteFunc(). + +=item * + +void *aStdioInitCookie = NULL + +Used as the argument for aStdioInitFunc(). + +=back + +=item * + +void Destroy(); + +The destructor of the interpreter. The class destructor calls +first this and then the Symbian CloseSTDLIB(). + +perl_destruct(), perl_free(), and PERL_SYS_TERM() are called +behind the curtains. + +=back + +=head2 Utility functions + +=over 4 + +=item * + +int Parse(int argc = 0, char *argv[] = 0, char *envp[] = 0); + +Prepare an interpreter for executing by parsing input as if a C main() +had been called. For example to parse a script, use argc of 2 and argv +of { "perl", script_name }. + +All arguments are optional: in case either argc or argv are zero, +argc of 3 and argv of { "perl", "-e", "0" } is assumed. + +PERL_SYS_INIT() and perl_parse() are called behind the curtains. + +Note that a call to Parse() is required before Run(). + +Returns zero if parsing was successful, non-zero if not (and the stderr +will get the error). + +=item * + +int Run() + +Start executing an interpeter. A Parse() must have been called before +a Run(): use 3 and { "", "-e", 0 } if you do not have an argv. + +Note that a call to Parse() is required before Run(). + +perl_run() is called behind the curtains. + +Returns zero if execution was successful, non-zero if not (and the stderr +will get the error). + +=item * + +int ParseAndRun(int argc, char *argv[], char *envp[]); + +Combined Parse() and Run(). The Run() is not run if the Parse() fails. + +Returns zero if parsing and execution were successful, non-zero if not. + +=item * + +TInt RunScriptL(TDesC& aFileName, int argc, char **argv, char *envp[]) + +Like ParseAndRun() but works for Symbian filenames (UTF-16LE). +The UTF-8 version of aFileName is always argv[argc-1], and argv[0] +is always "perl". + +=head2 Macros + +=over 4 + +=item * + +diTHX + +Set up my_perl from the current object (like dTHX). + +=item * + +diVAR + +Set up my_vars from the current object (like dVAR). + +=back + +=head2 Extending CPerlBase (subclassing, deriving from) + +Note that it probably isn't worth the trouble to try to wrap the +whole, rather large, Perl C API into a C++ API. Just use the C API. + +The protected members of the class are: + +=over 4 + +=item * + +PerlInterpreter* iPerl + +The Perl interpreter. + +=item * + +struct perl_vars* iVars + +The global variables of the interpreter. + +=item * + +TPerlState iState + +The state of the Perl interpreter. TPerlState is one of EPerlNone, +EPerlAllocated, EPerlConstructed, EPerlParsed, EPerlRunning, +EPerlTerminated, EPerlPaused (these two are currently unused +but in the future they might be used to indicate that the interpreter +was stopped either non-resumably or resumably for some reason), +EPerlSuccess (perl_run() succeeded), EPerlFailure (perl_run() failed), +EPerlDestroying. + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004-2005 Nokia. All rights reserved. + +=head1 LICENSE + +The CPerlBase class is licensed under the same terms as Perl itself. + +=cut + diff --git a/symbian/PerlRecog.cpp b/symbian/PerlRecog.cpp new file mode 100644 index 0000000..d2db544 --- /dev/null +++ b/symbian/PerlRecog.cpp @@ -0,0 +1,57 @@ +/* Copyright (c) 2004-2005 Nokia. All rights reserved. */ + +/* The PerlRecog application is licensed under the same terms as Perl itself. */ + +#include +#include +#include + +const TUid KUidPerlRecog = { 0x102015F7 }; +_LIT8(KPerlMimeType, "x-application/x-perl"); +_LIT8(KPerlSig, "#!/usr/bin/perl"); +const TInt KPerlSigLen = 15; + +class CApaPerlRecognizer : public CApaDataRecognizerType { + public: + CApaPerlRecognizer():CApaDataRecognizerType(KUidPerlRecog, EHigh) { + iCountDataTypes = 1; + } + virtual TUint PreferredBufSize() { return KPerlSigLen; } + virtual TDataType SupportedDataTypeL(TInt /* aIndex */) const { + return TDataType(KPerlMimeType); + } + private: + virtual void DoRecognizeL(const TDesC& aName, const TDesC8& aBuffer); +}; + +void CApaPerlRecognizer::DoRecognizeL(const TDesC& aName, const TDesC8& aBuffer) +{ + iConfidence = ENotRecognized; + + if (aBuffer.Length() >= KPerlSigLen && + aBuffer.Left(KPerlSigLen).Compare(KPerlSig) == 0) { + iConfidence = ECertain; + iDataType = TDataType(KPerlMimeType); + } else { + TParsePtrC p(aName); + + if ((p.Ext().CompareF(_L(".pl")) == 0) || + (p.Ext().CompareF(_L(".pm")) == 0)) { + iConfidence = ECertain; + iDataType = TDataType(KPerlMimeType); + } + } +} + +EXPORT_C CApaDataRecognizerType* CreateRecognizer() +{ + return new CApaPerlRecognizer; +} + +GLDEF_C TInt E32Dll(TDllReason /* aReason */) +{ + return KErrNone; +} + + + diff --git a/symbian/PerlRecog.mmp b/symbian/PerlRecog.mmp new file mode 100644 index 0000000..6850103 --- /dev/null +++ b/symbian/PerlRecog.mmp @@ -0,0 +1,9 @@ +TARGET PerlRecog.mdl +TARGETTYPE mdl +UID 0x10003A19 0x102015F7 +TARGETPATH \system\recogs +SOURCE PerlRecog.cpp +USERINCLUDE . +SYSTEMINCLUDE \epoc32\include +LIBRARY euser.lib efsrv.lib apmime.lib + diff --git a/symbian/README b/symbian/README new file mode 100644 index 0000000..95ed303 --- /dev/null +++ b/symbian/README @@ -0,0 +1,20 @@ +The PerlApp* files are a demonstration application for the CPerlBase +class, which is defined and implemented by the PerlBase* files. +The rest of the files are part of the Symbian base port. + +All files are Copyright (c) Nokia, 2004-2005, all rights reserved, +and licensed under the same terms as Perl itself. + +Once the 'sdkinstall' make target has been run in the top level, +the PerlApp can be built using the standard Symbian way: + + bldmake bldfiles + abld build wins udeb + abld build thumb urel + +and then packaged into a SIS by: + + makesis PerlApp.pkg + +-- + diff --git a/symbian/TODO b/symbian/TODO new file mode 100644 index 0000000..78dcd24 --- /dev/null +++ b/symbian/TODO @@ -0,0 +1,150 @@ +=head1 BASE PORT + +=head2 Console + +- The Console only does "ASCII" input: e.g. pressing the "2" + key five times, "aaaaa", does not produce "ä" ("a diaeresis"), + but instead the "2" key rotates through "abc2abc2...". + This is a pity because the Console is actually capable of full + Unicode input and output (if you have the fonts, that is). You + can verify this by entering e.g. the euro character, which is + U+20AC, well beyond U+00FF. I don't know why the full repertoire + of the keyboard is not available. +- Enhance the console? (line editing, full x-y movement, history) +- The role of the console needs to be rethought: the best way + would be to have the console visible in the same screen as + the GUI elements (an "embedded console"?) + +=head2 Core Language + +- the $^E does not work +- select() does not work (not our fault) +- starting external application: what now (0.1.0) works is: + - system("app"); + - system("app&"); + - and those with arguments: + - system("app arg1 arg2") + - system("app arg1 arg2 &") + but remember that a Symbian process does get only argv[0] + and argv[1]: all the arguments of the application are passed + in as a single argument ("arg1 arg2" in the above) + What does not work: + - piped open, in either direction + - qx/backtick/` + - fork/wait (these unlikely to ever work as in POSIX) + - IO redirection or filename globbing in system() + (since there is no POSIX shell beneath) + What might work in future: + - exec() might be made to work + - Symbian::spawn("cmd args") returning a process id (what does Win32 do?) + - Symbian::waitpid($spawned_pid) + +=head2 Platform + +- in S60 1.2 (at least in 3650 Nokia 3650 v3.11) setjmp/longjmp is + fragile (see Symbian FAQ-0929), intensive debugging and fix needed +- in S60 2.x (at least in Nokia 6630 v4.03.11) launching scripts via + FExplorer does not open up the console + +=head2 Unicode + +- Symbian has Unicode filenames, and Unicode all over the place. +- Encode and the use of Symbian Unicode in general + tie into the overall usefulness of PerlIO. + +=head2 Portability + +- Slash versus Backslash: where does one need to use "\\"? + writing Perl applications, where can one get away with using "/" ? + +=head2 Build + +- make xsbuild.pl much more robust (for building external extensions) +- MakeMaker? Pure PM, PM + XS? +- currently the PerlApp UID is in both config.pl (hardwired) and + in makesis.pl (computed), this is quite error prone +- Enable building also under Cygwin? + +=head1 PACKAGING + +- subdivide perlext.sis? +- pm-stripper: strip pod and comments, while inserting the appropriate + #line commands to keep linenumbers in sync. Shaves off easily 50% + of the code, making install packages smaller. +- Get MakeMaker to create SIS packages? In non-Win32? +- Symbian has APIs for opening .zip files +- Investigate Autrijus Tang's PAR format + http://www.autrijus.org/par-intro/ +- "makeplsis" to wrap a script.pl or dir/script.pl as a stand-alone + application (and SIS): unshift the "application home" to @INC and + chdir to that, then run the script.pl (renamed as default.pl) + +=head1 PerlBase + +- review for proper Symbian coding practices + +=head1 PerlApp + +- In "Run" see how one could show also the file extensions. +- when autostarting also offer to display the file (via Notes?) + instead of installing/running it? +- Allow passing command line options to scripts being run? +- Add "OneLiner" menu item? (-e, -M) (requires a UI form) +- Terminate/Pause menu entries? +- review for proper Symbian coding practices + +=head1 CORE LIBRARIES + +- Fix Devel::PPPort (worth it?) (Note that there is D::PPP 3.x out by now) +- Fix Encode to not to have writeable data: seems to be tricky indeed + because of copious global non-const data. +- Verify that the modified File::Spec::Win32 does work in Symbian. + (File::Spec::Epoc does not seem to be relevant?) +- What does Cwd really do since the concept of cwd is a bit fuzzy in Symbian. +- What should Sys::Hostname return? GPRS? BT? WLAN? +- ByteLoader problem: byterun.c does not see VERSION and XS_VERSION. +- POSIX problem: STDLIB POSIX is not that POSIX. + +=head1 REGRESSION SUITE + +- how to run the standard test suite on a Symbian device? + +=head1 CPAN LIBRARIES + +- Include/Package more modules (or work harder on getting CPAN.pm working?) + (but note that lib/**/*.pm is 3.5 megabytes, probably not worth including + all of it, even after pm-stripping): + - libnet + - Bundle::CPAN + - Archive::Tar + - Compress::Zlib (zlib?) (there is builtin gz support) + - Term::ReadKey (useless?) + - Term::ReadLine (useless?) + - Bundle::LWP + - URI + - HTML::TagSet + - HTML::Parser + - HTML::Entities + - HTML::HeadParser + - LWP + - Crypt::SSLeay? (ssl?) + - IO::Zlib? (zlib?) + - IMAP? + - Net::Telnet? + - Archive::Zip? + - Mail::Send? + - Date::Calc? + - XML? XML::Simple? (expat?) (there is builtin xml support) + - RSS? + - DBI + - DBD::SQLite? (sqlite?) + - SOAP? XML-RPC? + +=head1 FUTURE POSSIBILITIES + +- Remote console (Bluetooth/IR) +- S60 GUI support +- S60 PDA support +- Phone APIs +- S80 +- UIQ diff --git a/symbian/bld.inf b/symbian/bld.inf new file mode 100644 index 0000000..c448967 --- /dev/null +++ b/symbian/bld.inf @@ -0,0 +1,4 @@ +PRJ_MMPFILES +PerlApp.mmp +PerlRecog.mmp + diff --git a/symbian/config.pl b/symbian/config.pl new file mode 100644 index 0000000..e2cd2c6 --- /dev/null +++ b/symbian/config.pl @@ -0,0 +1,768 @@ +#!/usr/bin/perl -w + +# Copyright (c) 2004-2005 Nokia. All rights reserved. + +use strict; +use lib "symbian"; + +print "Configuring...\n"; +print "Configuring with: Perl version $] ($^X)\n"; + +do "sanity.pl"; + +my %VERSION = %{ do "version.pl" }; + +printf "Configuring for: Perl version $VERSION{REVISION}.%03d%03d\n", + $VERSION{VERSION}, $VERSION{SUBVERSION}; + +my $VERSION = "$VERSION{REVISION}$VERSION{VERSION}$VERSION{SUBVERSION}"; +my $R_V_SV = "$VERSION{REVISION}.$VERSION{VERSION}.$VERSION{SUBVERSION}"; + +my $SDK = do "sdk.pl"; +my %PORT = %{ do "port.pl" }; + +my ( $SYMBIAN_VERSION, $SDK_VERSION ) = ( $SDK =~ m!\\Symbian\\(.+?)\\(.+)$! ); + +if ($SDK eq 'C:\Symbian\Series60_1_2_CW') { + ( $SYMBIAN_VERSION, $SDK_VERSION ) = qw(6.1 1.2); +} + +my $WIN = $ENV{WIN} ; # 'wins', 'winscw' (from sdk.pl) +my $ARM = 'thumb'; # 'thumb', 'armi' +my $S60SDK = $ENV{S60SDK}; # qw(1.2 2.0 2.1 2.6) (from sdk.pl) + +my $UREL = $ENV{UREL}; # from sdk.pl +$UREL =~ s/-ARM-/$ARM/; +my $UARM = $ENV{UARM}; # from sdk.pl + +die "$0: SDK not recognized\n" + if !defined($SYMBIAN_VERSION) || !defined($SDK_VERSION) || !defined($S60SDK); + +die "$0: does not know which Windows compiler to use\n" + unless defined $WIN; + +print "Symbian $SYMBIAN_VERSION SDK $S60SDK ($WIN) installed at $SDK\n"; + +my $CWD = do "cwd.pl"; +print "Build directory $CWD\n"; + +die "$0: '+' in cwd does not work with SDK 1.2\n" + if $S60SDK eq '1.2' && $CWD =~ /\+/; + +my @unclean; +my @mmp; + +sub create_mmp { + my ( $target, $type, @x ) = @_; + my $miniperl = $target eq 'miniperl'; + my $perl = $target eq 'perl'; + my $mmp = "$target.mmp"; + my $targetpath = $miniperl + || $perl ? "TARGETPATH\t\\System\\Apps\\Perl" : ""; + if ( open( my $fh, ">$mmp" ) ) { + print "\t$mmp\n"; + push @mmp, $mmp; + push @unclean, $mmp; + print $fh <<__EOF__; +TARGET $target.$type +TARGETTYPE $type +$targetpath +EPOCHEAPSIZE 1024 8388608 +EPOCSTACKSIZE 65536 +EXPORTUNFROZEN +SRCDBG +__EOF__ + print $fh "MACRO\t__SERIES60_1X__\n" if $S60SDK =~ /^1\./; + print $fh "MACRO\t__SERIES60_2X__\n" if $S60SDK =~ /^2\./; + my ( @c, %c ); + @c = map { glob } qw(*.c); # Find the .c files. + @c = map { lc } @c; # Lowercase the names. + @c = grep { !/malloc\.c/ } @c; # Use the system malloc. + @c = grep { !/main\.c/ } @c; # main.c must be explicit. + push @c, map { lc } @x; + @c = map { s:^\.\./::; $_ } @c; # Remove the leading ../ + @c = map { $c{$_}++ } @c; # Uniquefy. + @c = sort keys %c; # Beautify. + + for (@c) { + print $fh "SOURCE\t\t$_\n"; + } + print $fh <<__EOF__; +SOURCEPATH $CWD +USERINCLUDE $CWD +USERINCLUDE $CWD\\ext\\DynaLoader +USERINCLUDE $CWD\\symbian +SYSTEMINCLUDE \\epoc32\\include\\libc +SYSTEMINCLUDE \\epoc32\\include +LIBRARY euser.lib +LIBRARY estlib.lib +__EOF__ + if ( $miniperl || $perl || $type eq 'dll' ) { + print $fh <<__EOF__; +LIBRARY charconv.lib +LIBRARY commonengine.lib +LIBRARY hal.lib +LIBRARY estor.lib +__EOF__ + } + if ( $type eq 'exe' ) { + print $fh <<__EOF__; +STATICLIBRARY ecrt0.lib +__EOF__ + } + if ($miniperl) { + print $fh <<__EOF__; +MACRO PERL_MINIPERL +__EOF__ + } + if ($perl) { + print $fh <<__EOF__; +MACRO PERL_PERL +__EOF__ + } + print $fh <<__EOF__; +MACRO PERL_CORE +MACRO MULTIPLICITY +MACRO PERL_IMPLICIT_CONTEXT +__EOF__ + unless ( $miniperl || $perl ) { + print $fh <<__EOF__; +MACRO PERL_GLOBAL_STRUCT +MACRO PERL_GLOBAL_STRUCT_PRIVATE +__EOF__ + } + close $fh; + } + else { + warn "$0: failed to open $mmp for writing: $!\n"; + } +} + +sub create_bld_inf { + if ( open( BLD_INF, ">bld.inf" ) ) { + print "\tbld.inf\n"; + push @unclean, "bld.inf"; + print BLD_INF <<__EOF__; +PRJ_PLATFORMS +${WIN} ${ARM} +PRJ_MMPFILES +__EOF__ + for (@mmp) { print BLD_INF $_, "\n" } + close BLD_INF; + } + else { + warn "$0: failed to open bld.inf for writing: $!\n"; + } +} + +my %config; + +sub load_config_sh { + if ( open( CONFIG_SH, "symbian/config.sh" ) ) { + while () { + if (/^(\w+)=['"]?(.*?)["']?$/) { + my ( $var, $val ) = ( $1, $2 ); + $val =~ s/x.y.z/$R_V_SV/gi; + $val =~ s/thumb/$ARM/gi; + $val = "'$SYMBIAN_VERSION'" if $var eq 'osvers'; + $val = "'$SDK_VERSION'" if $var eq 'sdkvers'; + $config{$var} = $val; + } + } + close CONFIG_SH; + } + else { + warn "$0: failed to open symbian\\config.sh for reading: $!\n"; + } +} + +sub create_config_h { + load_config_sh(); + if ( open( CONFIG_H, ">config.h" ) ) { + print "\tconfig.h\n"; + push @unclean, "config.h"; + if ( open( CONFIG_H_SH, "config_h.SH" ) ) { + while () { + last if /\#ifndef _config_h_/; + } + print CONFIG_H <<__EOF__; +/* + * Package name : perl + * Source directory : . + * Configuration time: + * Configured by : + * Target system : symbian + */ + +#ifndef _config_h_ +__EOF__ + while () { + last if /!GROK!THIS/; + s/\$(\w+)/exists $config{$1} ? $config{$1} : ""/eg; + s/^#undef\s+(\S+).+/#undef $1/g; + s:\Q/**/::; + print CONFIG_H; + } + close CONFIG_H_SH; + } + else { + warn "$0: failed to open ../config_h.SH for reading: $!\n"; + } + close CONFIG_H; + } + else { + warn "$0: failed to open config.h for writing: $!\n"; + } +} + +sub create_DynaLoader_cpp { + print "\text\\DynaLoader\\DynaLoader.cpp\n"; + system( +q[perl -Ilib lib\ExtUtils\xsubpp ext\DynaLoader\dl_symbian.xs >ext\DynaLoader\DynaLoader.cpp] + ) == 0 + or die "$0: creating DynaLoader.cpp failed: $!\n"; + push @unclean, 'ext\DynaLoader\DynaLoader.cpp'; + +} + +sub create_symbian_port_h { + print "\tsymbian\\symbian_port.h\n"; + if ( open( SYMBIAN_PORT_H, ">symbian/symbian_port.h" ) ) { + $S60SDK =~ /^(\d+)\.(\d+)$/; + my ($sdkmajor, $sdkminor) = ($1, $2); + print SYMBIAN_PORT_H <<__EOF__; +/* Copyright (c) 2004-2005, Nokia. All rights reserved. */ + +#ifndef __symbian_port_h__ +#define __symbian_port_h__ + +#define PERL_SYMBIANPORT_MAJOR $PORT{dll}->{MAJOR} +#define PERL_SYMBIANPORT_MINOR $PORT{dll}->{MINOR} +#define PERL_SYMBIANPORT_PATCH $PORT{dll}->{PATCH} + +#define PERL_SYMBIANSDK_FLAVOR L"Series 60" +#define PERL_SYMBIANSDK_MAJOR $sdkmajor +#define PERL_SYMBIANSDK_MINOR $sdkminor + +#endif /* #ifndef __symbian_port_h__ */ +__EOF__ + close(SYMBIAN_PORT_H); + push @unclean, 'symbian\symbian_port.h'; + } + else { + warn "$0: failed to open symbian/symbian_port.h for writing: $!\n"; + } +} + +sub create_perlmain_c { + print "\tperlmain.c\n"; + system( +q[perl -ne "print qq[ char *file = __FILE__;\n] if /dXSUB_SYS/;print;print qq[ newXS(\"DynaLoader::boot_DynaLoader\", boot_DynaLoader, file);\n] if /dXSUB_SYS/;print qq[EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);\n] if /Do not delete this line/" miniperlmain.c > perlmain.c] + ) == 0 + or die "$0: Creating perlmain.c failed: $!\n"; + push @unclean, 'perlmain.c'; +} + +sub create_PerlApp_pkg { + print "\tsymbian\\PerlApp.pkg\n"; + if ( open( PERLAPP_PKG, ">symbian\\PerlApp.pkg" ) ) { + my $APPS = $UREL; + if ($S60SDK ne '1.2' || $SDK =~ m/_CW$/) { # Do only if not in 1.2 VC. + $APPS =~ s!\\epoc32\\release\\(.+)\\$UARM$!\\epoc32\\data\\z\\system\\apps\\PerlApp!i; + } + print PERLAPP_PKG <<__EOF__; +; !!!!!! DO NOT EDIT THIS FILE !!!!!! +; This file is built by symbian\\config.pl. +; Any changes made here will be lost! +; +; PerlApp.pkg +; +; Note that the demo_pl needs to be run to create the demo .pl scripts. +; +; Languages +&EN; + +; Standard SIS file header +#{"PerlApp"},(0x102015F6),0,1,0 + +; Supports Series 60 v0.9 +(0x101F6F88), 0, 0, 0, {"Series60ProductID"} + +; Files +"$UREL\\PerlApp.APP"-"!:\\system\\apps\\PerlApp\\PerlApp.app" +"$UREL\\PerlRecog.mdl"-"!:\\system\\recogs\\PerlRecog.mdl" +"$APPS\\PerlApp.rsc"-"!:\\system\\apps\\PerlApp\\PerlApp.rsc" +"$APPS\\PerlApp.aif"-"!:\\system\\apps\\PerlApp\\PerlApp.aif" +__EOF__ + if ( open( DEMOS, "perl symbian\\demo_pl list |" ) ) { + while () { + chomp; + print PERLAPP_PKG qq["$_"-"!:\\Perl\\$_"\n]; + } + close(DEMOS); + } + close(PERLAPP_PKG); + } + else { + die "$0: symbian\\PerlApp.pkg: $!\n"; + } + push @unclean, 'symbian\PerlApp.pkg'; +} + +print "Creating...\n"; +create_mmp( + 'miniperl', 'exe', + 'miniperlmain.c', 'symbian\symbian_stubs.c', + 'symbian\PerlBase.cpp', 'symbian\symbian_utils.cpp', +); +create_mmp( + "perl", 'exe', + 'perlmain.c', 'symbian\symbian_stubs.c', + 'symbian\symbian_utils.cpp', 'symbian\PerlBase.cpp', + 'ext\DynaLoader\DynaLoader.cpp', +); + +create_mmp( + "perl$VERSION", 'dll', + 'symbian\symbian_dll.cpp', 'symbian\symbian_stubs.c', + 'symbian\symbian_utils.cpp', 'symbian\PerlBase.cpp', + 'ext\DynaLoader\DynaLoader.cpp', +); + +create_bld_inf(); +create_config_h(); +create_perlmain_c(); +create_symbian_port_h(); +create_DynaLoader_cpp(); +create_PerlApp_pkg(); + +if ( open( PERLAPP_MMP, ">symbian/PerlApp.mmp" ) ) { + my @MACRO; + push @MACRO, '__SERIES60_1X__' if $S60SDK =~ /^1\./; + push @MACRO, '__SERIES60_2X__' if $S60SDK =~ /^2\./; + print PERLAPP_MMP <<__EOF__; +// !!!!!! DO NOT EDIT THIS FILE !!!!!! +// This file is built by symbian\\config.pl. +// Any changes made here will be lost! +TARGET PerlApp.app +TARGETTYPE app +UID 0x100039CE 0x102015F6 +TARGETPATH \\system\\apps\\PerlApp +SRCDBG +EXPORTUNFROZEN +SOURCEPATH . +SOURCE PerlApp.cpp + +RESOURCE PerlApp.rss + +USERINCLUDE . +USERINCLUDE .. +USERINCLUDE \\symbian\\perl\\$R_V_SV\\include + +SYSTEMINCLUDE \\epoc32\\include +SYSTEMINCLUDE \\epoc32\\include\\libc + +LIBRARY apparc.lib +LIBRARY avkon.lib +LIBRARY bafl.lib +LIBRARY charconv.lib +LIBRARY commondialogs.lib +LIBRARY cone.lib +LIBRARY efsrv.lib +LIBRARY eikcore.lib +LIBRARY estlib.lib +LIBRARY euser.lib +LIBRARY perl$VERSION.lib + +AIF PerlApp.aif . PerlAppAif.rss +__EOF__ + if (@MACRO) { + for my $macro (@MACRO) { + print PERLAPP_MMP <<__EOF__; +MACRO $macro +__EOF__ + } + } + close(PERLAPP_MMP); + push @unclean, 'symbian\PerlApp.mmp'; +} +else { + warn "$0: failed to create symbian\\PerlApp.mmp"; +} + +if ( open( MAKEFILE, ">Makefile" ) ) { + my $perl = "perl$VERSION"; + my $windef1 = "$SDK\\Epoc32\\Build$CWD\\$perl\\$WIN\\$perl.def"; + my $windef2 = "..\\BWINS\\${perl}u.def"; + my $armdef1 = "$SDK\\Epoc32\\Build$CWD\\$perl\\$ARM\\$perl.def"; + my $armdef2 = "..\\BMARM\\${perl}u.def"; + print "\tMakefile\n"; + print MAKEFILE <<__EOF__; +help: + \@echo === Perl for Symbian === + \@echo Useful targets: + \@echo all win arm clean + \@echo perldll.sis perlext.sis perlsdk.zip + +WIN = ${WIN} +ARM = ${ARM} + +all: build + +build: rename_makedef build_win build_arm + +@unclean: symbian\\config.pl + perl symbian\\config.pl + +build_win: abld.bat win_perl.mf win_miniperl.mf win_${VERSION}.mf perldll_win + +build_vc6: abld.bat win_perl.mf win_miniperl.mf win_${VERSION}.mf vc6.mf perldll_win + +build_arm: abld.bat perl_arm miniperl_arm arm_${VERSION}.mf perldll_arm + +miniperl_win: miniperl.mmp abld.bat win_miniperl.mf rename_makedef + abld build \$(WIN) udeb miniperl + +miniperl_arm: miniperl.mmp abld.bat arm_miniperl.mf rename_makedef + abld build \$(ARM) $UARM miniperl + +miniperl: miniperl_win miniperl_arm + +perl: perl_win perl_arm + +perl_win: perl.mmp abld.bat win_perl.mf rename_makedef + abld build \$(WIN) perl + +perl_arm: perl.mmp abld.bat arm_perl.mf rename_makedef + abld build \$(ARM) $UARM perl + +perldll_win: perl${VERSION}_win freeze_win perl${VERSION}_win + +perl${VERSION}_win: perl$VERSION.mmp abld.bat rename_makedef + abld build \$(WIN) perl$VERSION + +perldll_arm: perl${VERSION}_arm freeze_arm perl${VERSION}_arm + +perl${VERSION}_arm: perl$VERSION.mmp arm_${VERSION}.mf abld.bat rename_makedef + abld build \$(ARM) $UARM perl$VERSION + +perldll perl$VERSION: perldll_win perldll_arm + +win: miniperl_win perl_win perldll_win + +arm: miniperl_arm perl_arm perldll_arm + +rename_makedef: + -ren makedef.pl nomakedef.pl + +# Symbian SDK has a makedef.pl of its own, +# and we don't need Perl's. +rerename_makedef: + -ren nomakedef.pl makedef.pl + +abld.bat abld: bld.inf + bldmake bldfiles + +makefiles: win.mf arm.mf vc6.mf + +vc6: win.mf vc6.mf build_vc6 + +win_miniperl.mf: abld.bat symbian\\config.pl + abld makefile \$(WIN) miniperl + echo > win_miniperl.mf + +win_perl.mf: abld.bat symbian\\config.pl + abld makefile \$(WIN) perl + echo > win_perl.mf + +win_${VERSION}.mf: abld.bat symbian\\config.pl + abld makefile \$(WIN) perl${VERSION} + echo > win_${VERSION}.mf + +symbian\\win.mf: + cd symbian; make win.mf + +win.mf: win_miniperl.mf win_perl.mf win_${VERSION}.mf symbian\\win.mf + +arm_miniperl.mf: abld.bat symbian\\config.pl + abld makefile \$(ARM) miniperl + echo > arm_miniperl.mf + +arm_perl.mf: abld.bat symbian\\config.pl + abld makefile \$(ARM) perl + echo > arm_perl.mf + +arm_${VERSION}.mf: abld.bat symbian\\config.pl + abld makefile \$(ARM) perl${VERSION} + echo > arm_${VERSION}.mf + +arm.mf: arm_miniperl.mf arm_perl.mf arm_${VERSION}.mf + +vc6.mf: abld.bat symbian\\config.pl + abld makefile vc6 + echo > vc6.mf + +PM = lib\\Config.pm lib\\Cross.pm lib\\lib.pm ext\\DynaLoader\\DynaLoader.pm ext\\DynaLoader\\XSLoader.pm ext\\Errno\\Errno.pm +POD = lib\\Config.pod + +pm: \$(PM) + +XLIB = -Ixlib\\symbian + +XSBOPT = --win=\$(WIN) --arm=\$(ARM) + +lib\\Config.pm: + copy symbian\\config.sh config.sh + perl -pi.bak -e "s:x\\.y\\.z+:$R_V_SV:g" config.sh + perl \$(XLIB) configpm --cross=symbian + copy xlib\\symbian\\Config.pm lib\\Config.pm + perl -pi.bak -e "s:x\\.y\\.z:$R_V_SV:g" lib\\Config.pm + perl -pi.bak -e "s:5\\.\\d+\\.\\d+:$R_V_SV:g" lib\\Config.pm + -perl -pi.bak -e "s:x\\.y\\.z:$R_V_SV:g" xlib\\symbian\\Config_heavy.pl + +lib\\lib.pm: + perl lib\\lib_pm.PL + +ext\\DynaLoader\\DynaLoader.pm: + -del /f ext\\DynaLoader\\DynaLoader.pm + perl -Ixlib\\symbian ext\\DynaLoader\\DynaLoader_pm.PL + perl -pi.bak -e "s/__END__//" DynaLoader.pm + copy /y DynaLoader.pm ext\\DynaLoader\\DynaLoader.pm + -del /f DynaLoader.pm DynaLoader.pm.bak + +ext\\DynaLoader\\XSLoader.pm: + perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) XSLoader + +ext\\Errno\\Errno.pm: + perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) Errno + +miniperlexe.sis: miniperl_arm symbian\\makesis.pl + perl \$(XLIB) symbian\\makesis.pl miniperl + +perlexe.sis: perl_arm symbian\\makesis.pl + perl \$(XLIB) symbian\\makesis.pl perl + + +allsis: all miniperlexe.sis perlexe.sis perldll.sis perllib.sis perlext.sis perlapp.sis + +perldll.sis perl$VERSION.sis: perldll_arm pm symbian\\makesis.pl + perl \$(XLIB) symbian\\makesis.pl perl${VERSION}dll + +perllib.sis: \$(PM) + perl \$(XLIB) symbian\\makesis.pl perl${VERSION}lib + +perlext.sis: perldll_arm buildext_sis + perl symbian\\makesis.pl perl${VERSION}ext + +EXT = Cwd Data::Dumper Devel::Peek Digest::MD5 Errno Fcntl File::Glob Filter::Util::Call IO List::Util MIME::Base64 PerlIO::scalar PerlIO::via SDBM_File Socket Storable Time::HiRes XSLoader attrs + +buildext: perldll symbian\\xsbuild.pl + perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) \$(EXT) + +buildext_sis: perldll.sis symbian\\xsbuild.pl + perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) --sis \$(EXT) + +cleanext: symbian\\xsbuild.pl + perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) --clean \$(EXT) + +distcleanext: symbian\\xsbuild.pl + perl \$(XLIB) symbian\\xsbuild.pl \$(XSBOPT) --distclean \$(EXT) + +sis makesis: miniperl perl perldll pm buildext perlapp.sis + perl \$(XLIB) symbian\\makesis.pl + +APIDIR = \\Symbian\\perl\\$R_V_SV + +sdkinstall: + -mkdir \\Symbian\\perl + -mkdir \\Symbian\\perl\\$R_V_SV + -mkdir \$(APIDIR)\\include + -mkdir \$(APIDIR)\\include\\symbian + -mkdir \$(APIDIR)\\lib + -mkdir \$(APIDIR)\\lib\\ExtUtils + -mkdir \$(APIDIR)\\pod + -mkdir \$(APIDIR)\\bin + -mkdir \$(BINDIR) + copy /y *.h \$(APIDIR)\\include + - copy /y *.inc \$(APIDIR)\\include + copy /y lib\\ExtUtils\\xsubpp \$(APIDIR)\\lib\\ExtUtils + copy /y lib\\ExtUtils\\typemap \$(APIDIR)\\lib\\ExtUtils + copy /y symbian\\xsbuild.pl \$(APIDIR)\\bin + copy /y symbian\\PerlBase.h \$(APIDIR)\\include + copy /y symbian\\symbian*.h \$(APIDIR)\\include\\symbian + copy /y symbian\\PerlBase.pod \$(APIDIR)\\pod + +RELDIR = $SDK\\epoc32\\release +RELWIN = \$(RELDIR)\\\$(WIN)\\udeb +RELARM = \$(RELDIR)\\\$(ARM)\\$UARM + +perlsdk.zip: perldll sdkinstall + zip -r perl${VERSION}sdk.zip \$(RELWIN)\\perl$VERSION.* \$(RELARM)\\perl$VERSION.* \$(APIDIR) + \@echo perl${VERSION}sdk.zip created. + +perlapp: sdkinstall perlapp_win perlapp_arm + +perlapp_win: config.h + cd symbian; make perlapp_win + +perlapp_arm: config.h + cd symbian; make perlapp_arm + +perlapp_demo_extract: + cd symbian; make perlapp_demo_extract + +perlapp.sis: perlapp_arm + cd symbian; make perlapp.sis + +perlapp.zip: + cd symbian; zip perlapp.zip PerlApp.* PerlRecog.* PerlBase.* demo_pl + +zip: perlsdk.zip perlapp.zip + +freeze: freeze_win freeze_arm + +freeze_win: + abld freeze \$(WIN) perl$VERSION + +freeze_arm: + abld freeze \$(ARM) perl$VERSION + +defrost: defrost_win defrost_arm + +defrost_win: + -del /f $windef1 + -del /f $windef2 + +defrost_arm: + -del /f $armdef1 + -del /f $armdef2 + +clean_win: abld.bat + abld clean \$(WIN) + +clean_arm: abld.bat + abld clean \$(ARM) + +clean: clean_win clean_arm rerename_makedef + -del /f \$(PM) + -del /f \$(POD) + -del /f lib\\Config.pm.bak + -del /f xlib\\symbian\\Config_heavy.pl + -rmdir /s /q xlib + -del /f config.sh + -del /f DynaLoader.pm ext\\DynaLoader\\DynaLoader.pm + -del /f ext\\DynaLoader\\Makefile + -del /f ext\\SDBM_File\\sdbm\\Makefile + -del /f symbian\\*.lst + -del /f abld.bat @unclean *.pkg *.sis *.zip + -del /f symbian\\abld.bat symbian\\*.sis symbian\\*.zip + -del /f symbian\\perl5*.pkg symbian\\miniperl.pkg + -del arm_*.mf win_*.mf vc6*.mf + -perl symbian\\xsbuild.pl \$(XSBOPT) --clean \$(EXT) + -rmdir /s /q perl${VERSION}_Data + -cd symbian; make clean + +reallyclean: abld.bat + abld reallyclean + +distclean: defrost reallyclean clean + -perl symbian\\xsbuild.pl \$(XSBOPT) --distclean \$(EXT) + -del /f config.h config.sh.bak symbian\\symbian_port.h + -del /f Makefile symbian\\PerlApp.mmp + -del /f BMARM\\*.def + -del /f *.cwlink *.resources *.pref + -del /f perl${VERSION}.xml perl${VERSION}.mcp uid.cpp + -rmdir /s /q BMARM + cd symbian; make distclean + -del /f symbian\\Makefile +__EOF__ + close MAKEFILE; +} +else { + warn "$0: failed to create Makefile: $!\n"; +} + +if ( open( MAKEFILE, ">symbian/Makefile")) { + my $wrap = $S60SDK eq '1.2' && $SDK !~ /_CW$/; + my $ABLD = $wrap ? 'perl b.pl': 'abld'; + print "\tsymbian/Makefile\n"; + print MAKEFILE <<__EOF__; +WIN = $WIN +ARM = $ARM +ABLD = $ABLD + +abld.bat: + bldmake bldfiles + +perlapp_win: abld.bat ..\\config.h PerlApp.h PerlApp.cpp + bldmake bldfiles + \$(ABLD) build \$(WIN) udeb + +perlapp_arm: ..\\config.h PerlApp.h PerlApp.cpp + bldmake bldfiles + \$(ABLD) build \$(ARM) $UARM + +win.mf: + bldmake bldfiles + abld makefile vc6 + +perlapp_demo_extract: + perl demo_pl extract + +perlapp.sis: perlapp_arm perlapp_demo_extract + -del /f perlapp.SIS + makesis perlapp.pkg + copy /y perlapp.SIS ..\\perlapp.SIS + +clean: + -perl demo_pl cleanup + -del /f perlapp.sis + -del /f b.pl + +distclean: clean + -del /f *.cwlink *.resources *.pref + -del /f PerlApp.xml PerlApp.mcp uid.cpp + -rmdir /s /q PerlApp_Data + -del /f abld.bat +__EOF__ + close(MAKEFILE); + if ($wrap) { + if ( open( B_PL, ">symbian/b.pl")) { + print B_PL <<'__EOF__'; +# abld.pl wrapper. + +# nmake doesn't like MFLAGS and MAKEFLAGS being set to -w and w. +delete $ENV{MFLAGS}; +delete $ENV{MAKEFLAGS}; + +system("abld @ARGV"); +__EOF__ + close(B_PL); + } else { + warn "$0: failed to create symbian/b.pl: $!\n"; + } + } +} else { + warn "$0: failed to create symbian/Makefile: $!\n"; +} + +print "Deleting...\n"; +for my $config ( + # Do not delete config.h here. + "config.sh", + "lib\\Config.pm", + "xlib\\symbian\\Config.pm", + "xlib\\symbian\\Config_heavy.pl", + ) { + print "\t$config\n"; + unlink($config); +} + +print <<__EOM__; +Configuring done. +Now you can run: + make all + make allsis +__EOM__ + +1; # Happy End. diff --git a/symbian/config.sh b/symbian/config.sh new file mode 100644 index 0000000..1c1fa01 --- /dev/null +++ b/symbian/config.sh @@ -0,0 +1,768 @@ +#!\\bin\\sh +PERL_CONFIG_SH='true' +_a='.a' +_o='.o' +afs='false' +afsroot='/afs' +alignbytes='4' +apiversion='5.005' +ar=':' +archlib='\\system\\libs\\perl\\x.y.z\\thumb-symbian' +archlibexp='\\system\\libs\\perl\\x.y.z\\thumb-symbian' +archname='thumb-symbian' +asctime_r_proto='0' +bin='\\system\\apps\\perl' +binexp='\\system\\apps\\perl' +bincompat5005='n' +byteorder='1234' +castflags='0' +cc='gcc' +cccdlflags='' +ccdlflags='' +charsize='1' +clocktype='clock_t' +cpp_stuff='42' +cppminus='-' +cpprun='gcc -E' +cppstdin='gcc -E' +crypt_r_proto='0' +ctermid_r_proto='0' +ctime_r_proto='0' +d_Gconvert='sprintf((b),"%.*g",(n),(x))' +d_PRIEUldbl='undef' +d_PRIFUldbl='undef' +d_PRIGUldbl='undef' +d_PRIXU64='undef' +d_PRId64='undef' +d_PRIeldbl='undef' +d_PRIfldbl='undef' +d_PRIgldbl='undef' +d_PRIi64='undef' +d_PRIo64='undef' +d_PRIu64='undef' +d_PRIx64='undef' +d_SCNfldbl='undef' +d__fwalk='undef' +d_access='undef' +d_accessx='undef' +d_aintl='undef' +d_alarm='undef' +d_archlib='define' +d_asctime_r='undef' +d_atolf='undef' +d_atoll='undef' +d_attribut='undef' +d_bcmp='undef' +d_bcopy='undef' +d_bsd='undef' +d_bsdgetpgrp='undef' +d_bsdsetpgrp='undef' +d_bzero='undef' +d_casti32='undef' +d_castneg='undef' +d_charvspr='undef' +d_chown='undef' +d_chroot='undef' +d_chsize='undef' +d_class='undef' +d_closedir='undef' +d_cmsghdr_s='undef' +d_const='define' +d_copysignl='undef' +d_crypt='undef' +d_crypt_r='undef' +d_csh='undef' +d_ctermid_r='undef' +d_ctime_r='undef' +d_cuserid='undef' +d_dbl_dig='undef' +d_dbminitproto='undef' +d_difftime='undef' +d_dirfd='undef' +d_dirnamlen='define' +d_dlerror='undef' +d_dlopen='undef' +d_dlsymun='undef' +d_dosuid='undef' +d_drand48_r='undef' +d_drand48proto='undef' +d_dup2='undef' +d_eaccess='undef' +d_endgrent='undef' +d_endgrent_r='undef' +d_endhent='undef' +d_endhostent_r='undef' +d_endnent='undef' +d_endnetent_r='undef' +d_endpent='undef' +d_endprotoent_r='undef' +d_endpwent='undef' +d_endpwent_r='undef' +d_endsent='undef' +d_endservent_r='undef' +d_eofnblk='undef' +d_eunice='undef' +d_faststdio='undef' +d_fchdir='undef' +d_fchmod='undef' +d_fchown='undef' +d_fcntl='undef' +d_fcntl_can_lock='undef' +d_fd_macros='undef' +d_fd_set='undef' +d_fds_bits='undef' +d_fgetpos='undef' +d_finite='undef' +d_finitel='undef' +d_flexfnam='undef' +d_flock='undef' +d_flockproto='undef' +d_fork='undef' +d_fp_class='undef' +d_fpathconf='undef' +d_fpclass='undef' +d_fpclassify='undef' +d_fpclassl='undef' +d_fpos64_t='undef' +d_frexpl='undef' +d_fs_data_s='undef' +d_fseeko='undef' +d_fsetpos='define' +d_fstatfs='undef' +d_fstatvfs='undef' +d_fsync='undef' +d_ftello='undef' +d_ftime='undef' +d_getcwd='define' +d_getespwnam='undef' +d_getfsstat='undef' +d_getgrent='undef' +d_getgrent_r='undef' +d_getgrgid_r='undef' +d_getgrnam_r='undef' +d_getgrps='undef' +d_gethbyaddr='define' +d_gethbyname='define' +d_gethent='undef' +d_gethname='define' +d_gethostbyaddr_r='undef' +d_gethostbyname_r='undef' +d_gethostent_r='undef' +d_gethostprotos='define' +d_getitimer='undef' +d_getlogin='undef' +d_getlogin_r='undef' +d_getmnt='undef' +d_getmntent='undef' +d_getnbyaddr='undef' +d_getnbyname='undef' +d_getnent='undef' +d_getnetbyaddr_r='undef' +d_getnetbyname_r='undef' +d_getnetent_r='undef' +d_getnetprotos='undef' +d_getpagsz='undef' +d_getpbyname='define' +d_getpbynumber='define' +d_getpent='undef' +d_getpgid='undef' +d_getpgrp2='undef' +d_getpgrp='undef' +d_getppid='undef' +d_getprior='undef' +d_getprotobyname_r='undef' +d_getprotobynumber_r='undef' +d_getprotoent_r='undef' +d_getprotoprotos='define' +d_getprpwnam='undef' +d_getpwent='undef' +d_getpwent_r='undef' +d_getpwnam_r='undef' +d_getpwuid_r='undef' +d_getsbyname='define' +d_getsbyport='define' +d_getsent='undef' +d_getservbyname_r='undef' +d_getservbyport_r='undef' +d_getservent_r='undef' +d_getservprotos='define' +d_getspent='undef' +d_getspnam='undef' +d_getspnam_r='undef' +d_gettimeod='define' +d_gmtime_r='undef' +d_gnulibc='undef' +d_grpasswd='undef' +d_hasmntopt='undef' +d_htonl='define' +d_ilogbl='undef' +d_index='undef' +d_inetaton='undef' +d_int64_t='undef' +d_isascii='undef' +d_isfinite='undef' +d_isinf='undef' +d_isnan='undef' +d_isnanl='undef' +d_killpg='undef' +d_lchown='undef' +d_ldbl_dig='undef' +d_libm_lib_version='undef' +d_link='undef' +d_localtime_r='undef' +d_locconv='undef' +d_lockf='undef' +d_longdbl='undef' +d_longlong='undef' +d_lseekproto='undef' +d_lstat='undef' +d_madvise='undef' +d_mblen='undef' +d_mbstowcs='undef' +d_mbtowc='undef' +d_memchr='define' +d_memcmp='define' +d_memcpy='define' +d_memmove='define' +d_memset='define' +d_mkdir='define' +d_mkdtemp='undef' +d_mkfifo='undef' +d_mkstemp='undef' +d_mkstemps='undef' +d_mktime='undef' +d_mmap='undef' +d_modfl='undef' +d_modfl_pow32_bug='undef' +d_modflproto='undef' +d_mprotect='undef' +d_msg='undef' +d_msg_ctrunc='undef' +d_msg_dontroute='undef' +d_msg_oob='undef' +d_msg_peek='undef' +d_msg_proxy='undef' +d_msgctl='undef' +d_msgget='undef' +d_msghdr_s='undef' +d_msgrcv='undef' +d_msgsnd='undef' +d_msync='undef' +d_munmap='undef' +d_mymalloc='undef' +d_nice='undef' +d_nl_langinfo='undef' +d_nv_preserves_uv='undef' +d_off64_t='undef' +d_old_pthread_create_joinable='undef' +d_oldpthreads='undef' +d_oldsock='undef' +d_open3='undef' +d_pathconf='undef' +d_pause='undef' +d_perl_otherlibdirs='undef' +d_phostname='undef' +d_pipe='undef' +d_poll='undef' +d_portable='undef' +d_procselfexe='undef' +d_pthread_atfork='undef' +d_pthread_attr_setscope='undef' +d_pthread_yield='undef' +d_pwage='undef' +d_pwchange='undef' +d_pwclass='undef' +d_pwcomment='undef' +d_pwexpire='undef' +d_pwgecos='undef' +d_pwpasswd='undef' +d_pwquota='undef' +d_qgcvt='undef' +d_quad='undef' +d_random_r='undef' +d_readdir64_r='undef' +d_readdir='define' +d_readdir_r='undef' +d_readlink='undef' +d_readv='undef' +d_recvmsg='undef' +d_rename='define' +d_rewinddir='define' +d_rmdir='define' +d_safebcpy='undef' +d_safemcpy='undef' +d_sanemcmp='undef' +d_sbrkproto='undef' +d_scalbnl='undef' +d_sched_yield='undef' +d_scm_rights='undef' +d_seekdir='define' +d_select='undef' +d_sem='undef' +d_semctl='undef' +d_semctl_semid_ds='undef' +d_semctl_semun='undef' +d_semget='undef' +d_semop='undef' +d_sendmsg='undef' +d_setegid='undef' +d_seteuid='undef' +d_setgrent='undef' +d_setgrent_r='undef' +d_setgrps='undef' +d_sethent='undef' +d_sethostent_r='undef' +d_setitimer='undef' +d_setlinebuf='undef' +d_setlocale='undef' +d_setlocale_r='undef' +d_setnent='undef' +d_setnetent_r='undef' +d_setpent='undef' +d_setpgid='undef' +d_setpgrp2='undef' +d_setpgrp='undef' +d_setprior='undef' +d_setproctitle='undef' +d_setprotoent_r='undef' +d_setpwent='undef' +d_setpwent_r='undef' +d_setregid='undef' +d_setresgid='undef' +d_setresuid='undef' +d_setreuid='undef' +d_setrgid='undef' +d_setruid='undef' +d_setsent='undef' +d_setservent_r='undef' +d_setsid='undef' +d_setvbuf='define' +d_sfio='undef' +d_shm='undef' +d_shmat='undef' +d_shmatprototype='undef' +d_shmctl='undef' +d_shmdt='undef' +d_shmget='undef' +d_sigaction='undef' +d_sigprocmask='undef' +d_sigsetjmp='undef' +d_sitecustomize='undef' +d_sockatmark='undef' +d_sockatmarkproto='undef' +d_socket='define' +d_socklen_t='undef' +d_sockpair='undef' +d_socks5_init='undef' +d_sqrtl='undef' +d_srand48_r='undef' +d_srandom_r='undef' +d_sresgproto='undef' +d_sresuproto='undef' +d_statblks='undef' +d_statfs_f_flags='undef' +d_statfs_s='undef' +d_statvfs='undef' +d_stdio_cnt_lval='undef' +d_stdio_ptr_lval='undef' +d_stdio_ptr_lval_nochange_cnt='undef' +d_stdio_ptr_lval_sets_cnt='undef' +d_stdio_stream_array='undef' +d_stdiobase='undef' +d_stdstdio='undef' +d_strchr='define' +d_strcoll='undef' +d_strctcpy='undef' +d_strerrm='strerror(e)' +d_strerror='define' +d_strerror_r='undef' +d_strftime='undef' +d_strlcat='undef' +d_strlcpy='undef' +d_strtod='define' +d_strtol='define' +d_strtold='undef' +d_strtoll='undef' +d_strtoq='undef' +d_strtoul='define' +d_strtoull='undef' +d_strtouq='undef' +d_strxfrm='undef' +d_suidsafe='undef' +d_symlink='undef' +d_syscall='undef' +d_syscallproto='undef' +d_sysconf='undef' +d_sysernlst='' +d_syserrlst='undef' +d_system='define' +d_tcgetpgrp='undef' +d_tcsetpgrp='undef' +d_telldir='define' +d_telldirproto='define' +d_time='define' +d_times='define' +d_tm_tm_gmtoff='undef' +d_tm_tm_zone='undef' +d_tmpnam_r='undef' +d_truncate='undef' +d_ttyname_r='undef' +d_tzname='undef' +d_u32align='define' +d_ualarm='undef' +d_umask='undef' +d_uname='undef' +d_union_semun='undef' +d_unordered='undef' +d_sitecustomize='undef' +d_usleep='define' +d_usleepproto='undef' +d_ustat='undef' +d_vendorarch='undef' +d_vendorbin='undef' +d_vendorlib='undef' +d_vfork='undef' +d_void_closedir='undef' +d_voidsig='undef' +d_voidtty='' +d_volatile='define' +d_vprintf='define' +d_wait4='undef' +d_waitpid='undef' +d_wcstombs='undef' +d_wctomb='undef' +d_writev='undef' +d_xenix='undef' +db_hashtype='u_int32_t' +db_prefixtype='size_t' +defvoidused=1 +direntrytype='struct dirent' +dlext='dll' +dlsrc='dl_symbian.xs' +doublesize='8' +drand01="((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))" +drand48_r_proto='0' +eagain='EAGAIN' +ebcdic='undef' +endgrent_r_proto='0' +endhostent_r_proto='0' +endnetent_r_proto='0' +endprotoent_r_proto='0' +endpwent_r_proto='0' +endservent_r_proto='0' +eunicefix=':' +exe_ext='.exe' +fflushNULL='undef' +fflushall='undef' +firstmakefile='makefile' +fpossize='4' +fpostype=fpos_t +freetype=void +full_ar=':' +getgrent_r_proto='0' +getgrgid_r_proto='0' +getgrnam_r_proto='0' +gethostbyaddr_r_proto='0' +gethostbyname_r_proto='0' +gethostent_r_proto='0' +getlogin_r_proto='0' +getnetbyaddr_r_proto='0' +getnetbyname_r_proto='0' +getnetent_r_proto='0' +getprotobyname_r_proto='0' +getprotobynumber_r_proto='0' +getprotoent_r_proto='0' +getpwent_r_proto='0' +getpwnam_r_proto='0' +getpwuid_r_proto='0' +getservbyname_r_proto='0' +getservbyport_r_proto='0' +getservent_r_proto='0' +getspnam_r_proto='0' +gidformat='"lu"' +gidsign='1' +gidsize='4' +gidtype=int +gmtime_r_proto='0' +groupstype=int +h_fcntl='false' +h_sysfile='true' +i16size='2' +i16type='short' +i32size='4' +i32type='long' +i64size='8' +i64type='int64_t' +i8size='1' +i8type='char' +i_arpainet='undef' +i_bsdioctl='' +i_crypt='undef' +i_db='undef' +i_dbm='undef' +i_dirent='define' +i_dld='undef' +i_dlfcn='undef' +i_fcntl='define' +i_float='undef' +i_fp='undef' +i_fp_class='undef' +i_gdbm='undef' +i_grp='undef' +i_ieeefp='undef' +i_inttypes='undef' +i_langinfo='undef' +i_libutil='undef' +i_limits='define' +i_locale='define' +i_machcthr='undef' +i_malloc='undef' +i_math='define' +i_memory='undef' +i_mntent='undef' +i_ndbm='undef' +i_netdb='define' +i_neterrno='undef' +i_netinettcp='undef' +i_niin='define' +i_poll='undef' +i_prot='undef' +i_pthread='undef' +i_pwd='define' +i_rpcsvcdbm='undef' +i_sfio='undef' +i_sgtty='undef' +i_shadow='undef' +i_socks='undef' +i_stdarg='define' +i_stddef='undef' +i_stdlib='define' +i_string='define' +i_sunmath='undef' +i_sysaccess='undef' +i_sysdir='undef' +i_sysfile='undef' +i_sysfilio='undef' +i_sysin='undef' +i_sysioctl='define' +i_syslog='undef' +i_sysmman='undef' +i_sysmode='undef' +i_sysmount='undef' +i_sysndir='undef' +i_sysparam='undef' +i_sysresrc='undef' +i_syssecrt='undef' +i_sysselct='undef' +i_syssockio='undef' +i_sysstat='define' +i_sysstatfs='undef' +i_sysstatvfs='undef' +i_systime='define' +i_systimek='undef' +i_systimes='define' +i_systypes='define' +i_sysuio='undef' +i_sysun='undef' +i_sysutsname='undef' +i_sysvfs='undef' +i_syswait='undef' +i_termio='undef' +i_termios='undef' +i_time='define' +i_unistd='define' +i_ustat='undef' +i_utime='undef' +i_values='undef' +i_varargs='undef' +i_varhdr='stdarg.h' +i_vfork='undef' +ignore_versioned_solibs='y' +inc_version_list='0' +inc_version_list_init='0' +installprefix='\\system' +installprefixexp='\\system' +installsitearch='\\system\\libs\\perl\\siteperl\\x.y.z\\thumb-symbian' +installsitelib='\\system\\libs\\perl\\siteperl\\x.y.z' +installstyle='lib\\perl5' +installusrbinperl='undef' +intsize='4' +ivdformat='"ld"' +ivsize='4' +ivtype='long' +lib_ext='.a' +lddlflags='' +ld=':' +ldflags='' +libc='stdlib' +libm_lib_version='0' +libperl='libperl.a' +localtime_r_proto='0' +longdblsize=8 +longlongsize=8 +longsize='4' +lseeksize=4 +lseektype=int +make='make' +malloctype='int*' +malloctype='void *' +modetype='mode_t' +modetype=int +multiarch='undef' +myarchname='thumb-symbian' +myuname='symbian' +need_va_copy='undef' +netdb_hlen_type='int' +netdb_host_type='const char *' +netdb_name_type='const char *' +netdb_net_type='unsigned long' +nroff='nroff' +nv_preserves_uv_bits='0' +nveformat='"e"' +nvfformat='"f"' +nvgformat='"g"' +nvsize='8' +nvtype='double' +o_nonblock='O_NONBLOCK' +obj_ext='.o' +old_pthread_create_joinable='' +optimize='-O2' +orderlib='false' +osname='symbian' +osvers='7.0s' +otherlibdirs='' +path_sep=';'; +phostname='hostname' +pidtype='int' +pm_apiversion='5.005' +privlib='\\system\\libs\\perl\\x.y.z' +privlibexp='\\system\\libs\\perl\\x.y.z' +procselfexe='' +prototype='undef' +ptrsize='4' +quadkind='4' +quadtype='int64_t' +randbits='48' +randfunc='drand48' +random_r_proto='0' +randseedtype='int' +ranlib=':' +rd_nodata='-1' +readdir64_r_proto='0' +readdir_r_proto='0' +sPRIEUldbl='"llE"' +sPRIFUldbl='"llF"' +sPRIGUldbl='"llG"' +sPRIXU64='"LX"' +sPRId64='"Ld"' +sPRIeldbl='' +sPRIfldbl='' +sPRIgldbl='' +sPRIi64='"Li"' +sPRIo64='"Lo"' +sPRIu64='"Lu"' +sPRIx64='"Lx"' +sSCNfldbl='' +sched_yield='sched_yield()' +scriptdir='\\system\\apps\\perl' +scriptdirexp='\\system\\apps\\perl' +sdkvers='' +seedfunc='srand' +selectminbits='32' +selecttype=int +setgrent_r_proto='0' +sethostent_r_proto='0' +setlocale_r_proto='0' +setnetent_r_proto='0' +setprotoent_r_proto='0' +setpwent_r_proto='0' +setservent_r_proto='0' +shmattype='void *' +shortsize=2 +sig_name_init='0' +sig_num_init='0' +sig_size='1' +signal_t=void +sitearch='\\system\\libs\\perl\\siteperl\\x.y.z\\thumb-symbian' +sitearchexp='\\system\\libs\\perl\\siteperl\\x.y.z\\thumb-symbian' +sitelib='\\system\\libs\\perl\\siteperl\\x.y.z' +sitelib_stem='\\system\\libs\\perl' +sitelibexp='\\system\\libs\\perl\\siteperl\\x.y.z' +siteprefix='\\system' +siteprefixexp='\\system' +sizesize=4 +sizetype=size_t +so='o' +socksizetype='unsigned int' +srand48_r_proto='0' +srandom_r_proto='0' +ssizetype=int +stdchar=char +stdio_base='((fp)->_IO_read_base)' +stdio_bufsiz='((fp)->_IO_read_end - (fp)->_IO_read_base)' +stdio_cnt='((fp)->_IO_read_end - (fp)->_IO_read_ptr)' +stdio_filbuf='' +stdio_ptr='((fp)->_IO_read_ptr)' +stdio_stream_array='' +strerror_r_proto='0' +targetarch='thumb-symbian' +timetype=time_t +tmpnam_r_proto='0' +touch='touch' +ttyname_r_proto='0' +u16size='2' +u16type='unsigned short' +u32size='4' +u32type='unsigned long' +u64size='8' +u64type='uint64_t' +u8size='1' +u8type='unsigned char' +uidformat='"lu"' +uidsign='1' +uidsize='4' +uidtype=int +uquadtype='uint64_t' +use5005threads='undef' +use64bitall='undef' +use64bitint='undef' +usecrosscompile='define' +usedl='undef' +usefaststdio='undef' +useithreads='undef' +uselargefiles='undef' +uselongdouble='undef' +usemallocwrap='define' +usemorebits='undef' +usemultiplicity='undef' +usemymalloc='n' +usenm='false' +useopcode='true' +useperlio='define' +useposix='true' +usereentrant='undef' +userelocatableinc='undef' +usesfio='false' +useshrplib='false' +usesitecustomize='undef' +usesocks='undef' +usethreads='undef' +usevendorprefix='n' +usevfork='false' +uvXUformat='"lX"' +uvoformat='"lo"' +uvsize='4' +uvtype='unsigned long' +uvuformat='"lu"' +vendorlib_stem='' +vendorlib='' +vendorlibexp='' +vendorarch='' +vendorarchexp='' +vendorprefix='' +vendorprefixexp='' +version='x.y.z' +uvxformat='"lx"' +versiononly='undef' +voidflags=1 +xs_apiversion='5.008' diff --git a/symbian/cwd.pl b/symbian/cwd.pl new file mode 100644 index 0000000..d3272d2 --- /dev/null +++ b/symbian/cwd.pl @@ -0,0 +1,6 @@ +use strict; +use Cwd; +my $CWD = getcwd(); +$CWD =~ s!^C:!!i; +$CWD =~ s!/!\\!g; +$CWD; diff --git a/symbian/demo_pl b/symbian/demo_pl new file mode 100644 index 0000000..fbba5f4 --- /dev/null +++ b/symbian/demo_pl @@ -0,0 +1,128 @@ +#!/usr/bin/perl -w + +# +# demo_pl +# +# A "self-extracting archive" for some demo scripts. +# +# hello - the classic +# helloyou - advanced classic +# httpget1 - simple sockets +# httpget2 - simple sockets done complex +# md5 - core extension +# time - system call +# times - more system calls +# + +use strict; + +unless (@ARGV && $ARGV[0] =~ /^(?:list|extract|cleanup)$/) { + die "$0: Usage: $0 [list|extract|cleanup]\n"; +} + +my $action = shift; +my $list = $action eq 'list'; +my $extract = $action eq 'extract'; +my $cleanup = $action eq 'cleanup'; + +my $fh; +while () { + if (/^-- (.+\.pl)$/) { + if ($cleanup) { + print "Deleting $1\n"; + unlink $1 or warn "$0: $1: $!\n"; + } elsif ($extract) { + defined $fh && close($fh); + open($fh, ">$1") or die "$0: '$1': $!\n"; + print "Extracting $1\n"; + } elsif ($list) { + print "$1\n"; + } + } else { + print $fh $_ if $extract; + } +} +defined $fh && close($fh); +exit(0); +__END__ +-- hello.pl +print "hello world!\n"; +-- helloyou.pl +print "What is your name?\n"; +chomp(my $name = ); +print "Hello, $name!\n"; +print "Amazing fact #1:\n"; +printf "Your name has\n%d character%s!\n", + length($name), length($name) == 1 ? "" : "s"; +print "Amazing fact #2:\n"; +printf "Your name is\n%s backwards!\n", scalar reverse $name; +-- httpget1.pl +print "(Using plain sockets)\n"; +use Socket; +print "Host? "; +my $host = ; +chomp($host); +$host = 'www.nokia.com' unless length $host; +my $port = 80; +my $iaddr = inet_aton($host) || die "no host: $host"; +my $paddr = sockaddr_in($port, $iaddr); +my $proto = getprotobyname("tcp"); +socket(S, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; +connect(S, $paddr) || die "connect: $!"; +print "$host:$port:\nConnected.\n"; +select(S); $| = 1; select(STDOUT); +print S "GET / HTTP/1.0\012\012" || die "GET /: $!"; +my @line; +print "Receiving...\n"; +while (my $line = ) { + push @line, $line; +} +close(S) || die "close: $!"; +printf "Got %d lines.\n", scalar @line; +-- httpget2.pl +use IO::Socket; +print "(Using IO::Socket)\n"; +print "Host? "; +my $host = ; +chomp($host); +$host = 'www.nokia.com' unless length $host; +my $port = 80; +my $remote = + IO::Socket::INET->new(Proto => "tcp", + PeerAddr => $host, + PeerPort => $port); +print "$host:$port:\nConnected.\n"; +select($remote); $| = 1; select(STDOUT); +print $remote "GET / HTTP/1.0\012\012" || die "GET /: $!"; +my @line; +print "Receiving...\n"; +while (my $line = <$remote>) { + push @line, $line; +} +close($remote) || die "close: $!"; +printf "Got %d lines.\n", scalar @line; +-- md5.pl +use Digest::MD5 'md5_hex'; +print "(Using Digest::MD5)\nMD5 of 'Perl' is:\n"; +print md5_hex('Perl'), "\n"; +-- time.pl +print "Running in $^O\n"; +print scalar localtime, "\n"; +-- times.pl +use Time::HiRes qw(time sleep); +print CORE::time(), "\n"; +print "Hires\n"; +print time(), "\n"; +print "Sleep 1.5 s...\n"; +sleep(1.5); +print time(), "\n"; +print "To one million...\n"; +my $t0 = time(); +print $t0, "\n"; +print "Cpu ", scalar times(), "\n"; +for(my $i = 0; $i < 1e6; $i++) {} +print "Cpu ", scalar times(), "\n"; +my $t1 = time(); +print $t1, "\n"; +print "Wall ", $t1 - $t0, "\n"; + diff --git a/symbian/install.cfg b/symbian/install.cfg new file mode 100644 index 0000000..8cc7b10 --- /dev/null +++ b/symbian/install.cfg @@ -0,0 +1,108 @@ +# install.cfg +# +# Copyright (c) 2004-2005 Nokia. All Rights Reserved. +# +# This file details what library files to include in the perlXYZlib.sis, +# and what extensions to build for the perlXYZext.sis. +# The lines beginning with "lib" are # included as-is from the lib/. +# The lines beginning with "ext" tell either how to build and package +# the extensions - or not. + +# +# Libraries. +# +lib AnyDBM_File.pm +lib AutoLoader.pm +lib base.pm +lib Benchmark.pm +lib Carp.pm +lib Carp/Heavy.pm +lib Cwd.pm +lib constant.pm +lib DBM_Filter.pm +lib Digest/base.pm +lib DirHandle.pm +lib Exporter.pm +lib Exporter/Heavy.pm +lib File/Basename.pm +lib File/Compare.pm +lib File/Copy.pm +lib File/DosGlob.pm +lib File/Find.pm +lib File/Path.pm +lib File/Spec.pm +lib File/Spec/Unix.pm +lib File/Spec/Win32.pm +lib File/Temp.pm +lib FileHandle.pm +lib Filter/Simple.pm +lib if.pm +lib integer.pm +lib lib.pm +lib Net/Cmd.pm +lib Net/Config.pm +lib Net/Domain.pm +lib Net/FTP.pm +lib Net/FTP/A.pm +lib Net/FTP/E.pm +lib Net/FTP/I.pm +lib Net/FTP/L.pm +lib Net/FTP/dataconn.pm +lib Net/NNTP.pm +lib Net/Netrc.pm +lib Net/Ping.pm +lib Net/POP3.pm +lib Net/SMTP.pm +lib Net/Time.pm +lib NEXT.pm +lib overload.pm +lib SelectSaver.pm +lib strict.pm +lib Symbol.pm +lib UNIVERSAL.pm +# lib utf8.pm +# lib utf8_heavy.pl +lib vars.pm +lib warnings.pm +lib warnings/register.pm +# +# Extensions. +# +ext attrs +ext Cwd +ext Data/Dumper +ext Devel/Peek +ext Digest/MD5 +ext Errno +ext Fcntl CONST +ext File/Glob CONST +ext Filter/Util/Call +ext IO +ext List/Util +ext MIME/Base64 +ext PerlIO/scalar +ext PerlIO/via +ext SDBM_File -sdbm/db?.c -sdbm/util.c +ext Socket CONST +ext Storable +ext Time/HiRes CONST +ext XSLoader +# ext B ERROR +# ext ByteLoader byterun.c ERROR VERSION +# ext Devel/DProf nonconst +# ext Devel/PPPort PORT +# ext Encode nonconst Encode/encode.h def_t.c encengine.c +# ext I18N/Langinfo PORT +# ext IPC/SysV PORT +# ext Opcode ERROR +# ext PerlIO/encoding Encode +# ext POSIX CONST USELESS +# ext re ERROR +# ext Sys/Hostname PORT +# ext Sys/Syslog PORT +# ext threads PORT +# ext threads/shared PORT +# ext Unicode/Normalize nonconst +# ext XS/APItest USELESS +# ext XS/Typemap nonconst USELESS + diff --git a/symbian/makesis.pl b/symbian/makesis.pl new file mode 100644 index 0000000..1ee5e8d --- /dev/null +++ b/symbian/makesis.pl @@ -0,0 +1,185 @@ +#!/usr/bin/perl -w + +# Copyright (c) 2004-2005 Nokia. All rights reserved. + +use strict; +use lib "symbian"; + +do "sanity.pl"; + +my %VERSION = %{ do "version.pl" }; +my $VERSION = "$VERSION{REVISION}$VERSION{VERSION}$VERSION{SUBVERSION}"; +my $R_V_SV = "$VERSION{REVISION}.$VERSION{VERSION}.$VERSION{SUBVERSION}"; + +my $SDK = do "sdk.pl"; +my $UID = do "uid.pl"; +my %PORT = %{ do "port.pl" }; + +my $ARM = 'thumb'; # TODO +my $S60SK = $ENV{S60SDK}; # from sdk.pl + +my $UREL = $ENV{UREL}; # from sdk.pl +$UREL =~ s/-ARM-/$ARM/; + +my $app = '!:\System\Apps\Perl'; +my $lib = '!:\System\Libs'; + +my @target = @ARGV + ? @ARGV + : ( + "miniperl", "perl", + "perl${VERSION}dll", "perl${VERSION}lib", + "perl${VERSION}ext" + ); + +my %suffix; +@suffix{ "miniperl", "perl", "perl$VERSION" } = ( "exe", "exe", "dll", ); + +for my $target (@target) { + $target = "perl${VERSION}" if $target eq "perl${VERSION}dll"; + + my %copy; + my $pkg = "$target.pkg"; + print "\nCreating $pkg...\n"; + + my $suffix = $suffix{$target} || ""; + my $dst = $suffix eq "dll" ? $lib : $app; + + my $srctarget = "$UREL\\$target.$suffix"; + + if ( $target =~ /^(miniperl|perl|perl${VERSION}(?:dll)?)$/ ) { + $copy{$srctarget} = "$dst\\$target.$suffix"; + print "\t$target.$suffix\n"; + } + if ( $target eq "perl${VERSION}lib" ) { + print "Libraries...\n"; + + print "\tConfig.pm\n"; + $copy{"lib\\Config.pm"} = + "$lib\\Perl\\$R_V_SV\\thumb-symbian\\Config.pm"; + + print "\tConfig_heavy.pl\n"; + $copy{"xlib\\symbian\\Config_heavy.pl"} = + "$lib\\Perl\\$R_V_SV\\thumb-symbian\\Config_heavy.pl"; + + print "\tDynaLoader.pm\n"; + $copy{"ext\\DynaLoader\\DynaLoader.pm"} = + "$lib\\Perl\\$R_V_SV\\DynaLoader.pm"; + + print "\tErrno.pm\n"; + $copy{"ext\\Errno\\Errno.pm"} = "$lib\\Perl\\$R_V_SV\\Errno.pm"; + + open( my $cfg, "symbian/install.cfg" ) + or die "$!: symbian/install.cfg: $!\n"; + while (<$cfg>) { + next unless /^lib\s+(.+)/; + chomp; + my $f = $1; + $f =~ s:/:\\:g; + $copy{"lib\\$f"} = "$lib\\Perl\\$R_V_SV\\$f"; + print "\t$f\n"; + } + close($cfg); + } + + if ( $target eq "perl${VERSION}ext" ) { + my @lst = glob("symbian/*.lst"); + print "Extensions...\n"; + print "\t(none found)\n" unless @lst; + for my $lst (@lst) { + $lst =~ m:^symbian/(.+)\.:; + my $ext = $1; + $ext =~ s!-!::!g; + print "\t$ext\n"; + if ( open( my $pkg, $lst ) ) { + while (<$pkg>) { + if (m!^"(.+)"-"(.+)"$!) { + my ( $src, $dst ) = ( $1, $2 ); + $copy{$src} = $dst; + } + else { + warn "$0: $lst: $.: unknown syntax\n"; + } + } + close($pkg); + } + else { + warn "$0: $lst: $!\n"; + } + } + } + + for my $file ( keys %copy ) { + warn "$0: $file does not exist\n" unless -f $file; + } + + my @copy = map { qq["$_"-"$copy{$_}"] } sort keys %copy; + my $copy = join( "\n", @copy ); + + my %UID = ( + "miniperl" => 0, + "perl" => 0, + "perl${VERSION}" => $UID + 0, + "perl${VERSION}dll" => $UID + 0, + "perl${VERSION}ext" => $UID + 1, + "perl${VERSION}lib" => $UID + 2, + + # app = + 3 + # rec = + 4 + ); + + die "$0: target has no UID\n" unless defined $UID{$target}; + + my $uid = sprintf( "0x%08X", $UID{$target} ); + + my ( $MAJOR, $MINOR, $PATCH ) = ( 0, 0, 0 ); + + if ( $target =~ m:^perl$VERSION(dll|ext|lib)?$: ) { + my $pkg = defined $1 ? $1 : "dll"; + $MAJOR = $PORT{$pkg}->{MAJOR}; + $MINOR = $PORT{$pkg}->{MINOR}; + $PATCH = $PORT{$pkg}->{PATCH}; + } + + die "$0: Bad version for $target\n" + unless defined $MAJOR + && ( $MAJOR eq 0 || $MAJOR > 0 ) + && defined $MINOR + && ( $MINOR eq 0 || $MINOR > 0 ) + && defined $PATCH + && ( $PATCH eq 0 || $PATCH > 0 ); + + open PKG, ">$pkg" or die "$0: failed to create $pkg: $!\n"; + print PKG <<__EOF__; +; \u$target installation script +; +; The supported languages +&EN; +; +; The installation name and header data +; +#{"\u$target"},($uid),$MAJOR,$MINOR,$PATCH +; +; Private key and certificate (unused) +; +;* "\u$target.key", "\u$target.cer" +; +; Supports Series60 v0.9 +(0x101F6F88), 0, 0, 0, {"Series60ProductID"} +; The files to install +; +$copy +__EOF__ + close PKG; + + print "Created $pkg\n"; + + print "Running makesis...\n"; + + unlink("$target.sis"); + + system("makesis $pkg") == 0 + || die "$0: makesis $pkg failed: $!\n"; +} + +exit(0); diff --git a/symbian/port.pl b/symbian/port.pl new file mode 100644 index 0000000..affb42c --- /dev/null +++ b/symbian/port.pl @@ -0,0 +1,6 @@ +{ + dll => { MAJOR => 0, MINOR => 1, PATCH => 0 }, + ext => { MAJOR => 0, MINOR => 1, PATCH => 0 }, + lib => { MAJOR => 0, MINOR => 1, PATCH => 0 }, +} + diff --git a/symbian/sanity.pl b/symbian/sanity.pl new file mode 100644 index 0000000..eb50244 --- /dev/null +++ b/symbian/sanity.pl @@ -0,0 +1,28 @@ +use strict; + +if (exists $ENV{'!C:'}) { + print "You are running this under Cygwin, aren't you?\n"; + print "I'm sorry but only cmd.exe will work.\n"; + exit(1); +} + +if (# SDK 2.x + $ENV{PATH} !~ m!c:\\program files\\common files\\symbian\\tools!i + && + # SDK 1.2 + $ENV{PATH} !~ m!c:\\symbian\\6.1\\shared\\epoc32\\tools!i) { + print "I think you have not installed the Symbian SDK.\n"; + exit(1); +} + +unless (-f "symbian/symbianish.h") { + print "You must run this in the top level directory.\n"; + exit(1); +} + +if ($] < 5.008) { + print "You must configure with Perl 5.8 or later.\n"; + exit(1); +} + +1; diff --git a/symbian/sdk.pl b/symbian/sdk.pl new file mode 100644 index 0000000..1dc4d2f --- /dev/null +++ b/symbian/sdk.pl @@ -0,0 +1,48 @@ +use strict; + +my $SDK; +my $WIN; + +if ($ENV{PATH} =~ m!\\Symbian\\(.+?)\\gcc\\bin!) { + my $cc = $1; + $WIN = $cc =~ m!_CW!i ? 'winscw' : 'wins'; + $ENV{WIN} = $WIN; + if ($cc =~ m!Series60_v20!) { + $ENV{S60SDK} = '2.0'; + } elsif ($cc =~ m!Series60_v21!) { + $ENV{S60SDK} = '2.1'; + } elsif ($cc =~ m!S60_2nd_FP2!) { + $ENV{S60SDK} = '2.6'; + } +} + +if (open(GCC, "gcc -v 2>&1|")) { + while () { + if (/Reading specs from ((?:C:)?\\Symbian.+?)\\Epoc32\\/i) { + $SDK = $1; + # The S60SDK tells the Series 60 SDK version. + if ($SDK eq 'C:\Symbian\6.1\Shared') { # Visual C. + $SDK = 'C:\Symbian\6.1\Series60'; + $ENV{S60SDK} = '1.2'; + } elsif ($SDK eq 'C:\Symbian\Series60_1_2_CW') { # CodeWarrior. + $ENV{S60SDK} = '1.2'; + } + last; + } + } + close GCC; +} else { + die "$0: failed to run gcc: $!\n"; +} + +my $UARM = $ENV{UARM} ? $ENV{UARM} : "urel"; +my $UREL = "$SDK\\epoc32\\release\\-ARM-\\$UARM"; +if ($SDK eq 'C:\Symbian\6.1\Series60' && $ENV{WIN} eq 'winscw') { + $UREL = "C:\\Symbian\\Series60_1_2_CW\\epoc32\\release\\-ARM-\\urel"; +} +$ENV{UREL} = $UREL; +$ENV{UARM} = $UARM; + +die "$0: failed to locate the Symbian SDK\n" unless defined $SDK; + +$SDK; diff --git a/symbian/symbian_dll.cpp b/symbian/symbian_dll.cpp new file mode 100644 index 0000000..92a06b8 --- /dev/null +++ b/symbian/symbian_dll.cpp @@ -0,0 +1,20 @@ +/* + * symbian_dll.cpp + * + * Copyright (c) Nokia 2004-2005. All rights reserved. + * This code is licensed under the same terms as Perl itself. + * + */ + +#define SYMBIAN_DLL_CPP +#include +#include "PerlBase.h" + +EXPORT_C GLDEF_C TInt E32Dll(TDllReason /*aReason*/) { return KErrNone; } + +extern "C" { + EXPORT_C void* symbian_get_vars(void) { return Dll::Tls(); } + EXPORT_C void symbian_set_vars(const void *p) { Dll::SetTls((TAny*)p); } + EXPORT_C void symbian_unset_vars(void) { Dll::SetTls(0); } +} + diff --git a/symbian/symbian_proto.h b/symbian/symbian_proto.h new file mode 100644 index 0000000..f50de34 --- /dev/null +++ b/symbian/symbian_proto.h @@ -0,0 +1,72 @@ +/* + * symbian_proto.h + * + * Copyright (c) Nokia 2004-2005. All rights reserved. + * This code is licensed under the same terms as Perl itself. + * + */ + +#ifndef SYMBIAN_PROTO_H +#define SYMBIAN_PROTO_H + +#include +#include + +#if defined(PERL_CORE) || defined(PERL_EXT) + +/* We can't include the unconditionally + * since it has prototypes conflicting with the gcc builtins. */ +extern void *memchr(const void *s, int c, size_t n); +#ifndef DL_SYMBIAN_XS +/* dl_symbian.xs needs to see the C++ prototype of memset() instead */ +extern void *memset(void *s, int c, size_t n); +extern size_t strlen(const char *s); +#endif +extern void *memmove(void *dst, const void *src, size_t n); +extern char *strcat(char *dst, const char *src); +extern char *strchr(const char *s, int c); +extern char *strerror(int errnum); +extern int strncmp(const char *s1, const char *s2, size_t n); +extern char *strrchr(const char *s, int c); + +extern int setmode(int fd, long flags); + +#ifndef __GNUC__ +#define memcpy _e32memcpy /* GCC intrinsic */ +extern void *memcpy(const void *s1, const void *s2, size_t n); +extern int strcmp(const char *s1, const char *s2); +extern char* strcpy(char *dst, const char *src); +extern char* strncpy(char *dst, const char *src, size_t n); +#endif + +#endif /* PERL_CORE || PERL_EXT */ + +#if defined(SYMBIAN_DLL_CPP) || defined(SYMBIAN_UTILS_CPP) || defined(PERLBASE_CPP) +# define PERL_SYMBIAN_START_EXTERN_C extern "C" { +# define PERL_SYMBIAN_EXPORT_C EXPORT_C +# define PERL_SYMBIAN_END_EXTERN_C } +#else +# define PERL_SYMBIAN_START_EXTERN_C +# define PERL_SYMBIAN_EXPORT_C +# define PERL_SYMBIAN_END_EXTERN_C +#endif + +PERL_SYMBIAN_START_EXTERN_C +PERL_SYMBIAN_EXPORT_C int symbian_sys_init(int *argcp, char ***argvp); +PERL_SYMBIAN_EXPORT_C void* symbian_get_vars(void); +PERL_SYMBIAN_EXPORT_C void symbian_set_vars(const void *); +PERL_SYMBIAN_EXPORT_C void symbian_unset_vars(void); +PERL_SYMBIAN_EXPORT_C SSize_t symbian_read_stdin(const int fd, char *b, int n); +PERL_SYMBIAN_EXPORT_C SSize_t symbian_write_stdout(const int fd, const char *b, int n); +PERL_SYMBIAN_EXPORT_C char* symbian_get_error_string(const int error); +PERL_SYMBIAN_EXPORT_C void symbian_sleep_usec(const long usec); +PERL_SYMBIAN_EXPORT_C int symbian_get_cpu_time(long* sec, long* usec); +PERL_SYMBIAN_EXPORT_C clock_t symbian_times(struct tms* buf); +PERL_SYMBIAN_EXPORT_C int symbian_usleep(unsigned int usec); +PERL_SYMBIAN_EXPORT_C int symbian_do_aspawn(void* vreally, void *vmark, void* sp); +PERL_SYMBIAN_EXPORT_C int symbian_do_spawn(const char* command); +PERL_SYMBIAN_EXPORT_C int symbian_do_spawn_nowait(const char* command); +PERL_SYMBIAN_END_EXTERN_C + +#endif /* !SYMBIAN_PROTO_H */ + diff --git a/symbian/symbian_stubs.c b/symbian/symbian_stubs.c new file mode 100644 index 0000000..1505698 --- /dev/null +++ b/symbian/symbian_stubs.c @@ -0,0 +1,112 @@ +/* + * symbian_stubs.c + * + * Copyright (c) Nokia 2004-2005. All rights reserved. + * This code is licensed under the same terms as Perl itself. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "symbian_stubs.h" + +static int setENOSYS(void) { errno = ENOSYS; return -1; } + +uid_t getuid(void) { return setENOSYS(); } +gid_t getgid(void) { return setENOSYS(); } +uid_t geteuid(void) { return setENOSYS(); } +gid_t getegid(void) { return setENOSYS(); } + +int setuid(uid_t uid) { return setENOSYS(); } +int setgid(gid_t gid) { return setENOSYS(); } +int seteuid(uid_t uid) { return setENOSYS(); } +int setegid(gid_t gid) { return setENOSYS(); } + +int execv(const char* path, char* const argv []) { return setENOSYS(); } +int execvp(const char* path, char* const argv []) { return setENOSYS(); } + +#ifndef USE_PERLIO +FILE *popen(const char *command, const char *mode) { return 0; } +int pclose(FILE *stream) { return setENOSYS(); } +#endif +int pipe(int fd[2]) { return setENOSYS(); } + +int setmode(int fd, long flags) { return -1; } + +_sig_func_ptr signal(int signum, _sig_func_ptr handler) { return (_sig_func_ptr)setENOSYS(); } +int kill(pid_t pid, int signum) { return setENOSYS(); } +pid_t wait(int *status) { return setENOSYS(); } + +#if PERL_VERSION <= 8 +void Perl_my_setenv(pTHX_ char *var, char *val) { } +#else +void Perl_my_setenv(pTHX_ const char *var, const char *val) { } +#endif + +bool Perl_do_exec(pTHX_ char *cmd) { return FALSE; } +bool Perl_do_exec3(pTHX_ char *cmd, int fd, int flag) { return FALSE; } + +int Perl_do_spawn(pTHX_ char *cmd) { return symbian_do_spawn(cmd); } +int Perl_do_aspawn(pTHX_ SV *really, SV** mark, SV **sp) { return symbian_do_aspawn(really, mark, sp); } + +static const struct protoent protocols[] = { + { "tcp", 0, 6 }, + { "udp", 0, 17 } +}; + +/* The protocol field (the last) is left empty to save both space + * and time because practically all services have both tcp and udp + * allocations in IANA. */ +static const struct servent services[] = { + { "http", 0, 80, 0 }, /* Optimization. */ + { "https", 0, 443, 0 }, + { "imap", 0, 143, 0 }, + { "imaps", 0, 993, 0 }, + { "smtp", 0, 25, 0 }, + { "irc", 0, 194, 0 }, + + { "ftp", 0, 21, 0 }, + { "ssh", 0, 22, 0 }, + { "tftp", 0, 69, 0 }, + { "pop3", 0, 110, 0 }, + { "sftp", 0, 115, 0 }, + { "nntp", 0, 119, 0 }, + { "ntp", 0, 123, 0 }, + { "snmp", 0, 161, 0 }, + { "ldap", 0, 389, 0 }, + { "rsync", 0, 873, 0 }, + { "socks", 0, 1080, 0 } +}; + +struct protoent* getprotobynumber(int number) { + int i; + for (i = 0; i < sizeof(protocols)/sizeof(struct protoent); i++) + if (protocols[i].p_proto == number) + return (struct protoent*)(&(protocols[i])); + return 0; +} + +struct protoent* getprotobyname(const char* name) { + int i; + for (i = 0; i < sizeof(protocols)/sizeof(struct protoent); i++) + if (strcmp(name, protocols[i].p_name) == 0) + return (struct protoent*)(&(protocols[i])); + return 0; +} + +struct servent* getservbyname(const char* name, const char* proto) { + int i; + for (i = 0; i < sizeof(services)/sizeof(struct servent); i++) + if (strcmp(name, services[i].s_name) == 0) + return (struct servent*)(&(services[i])); + return 0; +} + +struct servent* getservbyport(int port, const char* proto) { + int i; + for (i = 0; i < sizeof(services)/sizeof(struct servent); i++) + if (services[i].s_port == port) + return (struct servent*)(&(services[i])); + return 0; +} + diff --git a/symbian/symbian_stubs.h b/symbian/symbian_stubs.h new file mode 100644 index 0000000..ab6b961 --- /dev/null +++ b/symbian/symbian_stubs.h @@ -0,0 +1,22 @@ +/* + * symbian_stubs.h + * + * Copyright (c) Nokia 2004-2005. All rights reserved. + * This code is licensed under the same terms as Perl itself. + * + */ + +#ifndef PERL_SYMBIAN_STUBS_H +#define PERL_SYMBIAN_STUBS_H + +int execv(const char* path, char* const argv []); +int execvp(const char* path, char* const argv []); + +#ifndef USE_PERLIO +FILE *popen(const char *command, const char *mode); +int pclose(FILE *stream); +#endif +int pipe(int fd[2]); + +#endif /* PERL_SYMBIAN_STUBS_H */ + diff --git a/symbian/symbian_utils.cpp b/symbian/symbian_utils.cpp new file mode 100644 index 0000000..16e911c --- /dev/null +++ b/symbian/symbian_utils.cpp @@ -0,0 +1,299 @@ +/* + * symbian_utils.cpp + * + * Copyright (c) Nokia 2004-2005. All rights reserved. + * This code is licensed under the same terms as Perl itself. + * + */ + +#define SYMBIAN_UTILS_CPP +#include +#include +#include +#include +#include + +#include +#include + +#include "PerlBase.h" + +extern "C" { + EXPORT_C int symbian_sys_init(int *argcp, char ***argvp) + { +#ifdef PERL_GLOBAL_STRUCT /* Avoid unused variable warning. */ + dVAR; +#endif + (void)times(&PL_timesbase); + return 0; + } + EXPORT_C SSize_t symbian_read_stdin(const int fd, char *b, int n) + { +#ifdef PERL_GLOBAL_STRUCT /* Avoid unused variable warning. */ + dVAR; +#endif + return ((CPerlBase*)PL_appctx)->ConsoleRead(fd, b, n); + } + EXPORT_C SSize_t symbian_write_stdout(const int fd, const char *b, int n) + { +#ifdef PERL_GLOBAL_STRUCT /* Avoid unused variable warning. */ + dVAR; +#endif + return ((CPerlBase*)PL_appctx)->ConsoleWrite(fd, b, n); + } + static const char NullErr[] = ""; + EXPORT_C char* symbian_get_error_string(const TInt error) + { + dTHX; + if (error >= 0) + return strerror(error); + CTextResolver* textResolver = CTextResolver::NewL(); + CleanupStack::PushL(textResolver); + TBuf buf16; + TBuf8 buf8; + if (error != KErrNone) + buf16 = textResolver->ResolveError(error); + if (buf16.Length()) { + if (CnvUtfConverter::ConvertFromUnicodeToUtf8(buf8, buf16) != + KErrNone) { + CleanupStack::PopAndDestroy(textResolver); + return (char*)NullErr; + } + } + SV* sv = Perl_get_sv(aTHX_ "\005", TRUE); /* $^E or ${^OS_ERROR} */ + if (!sv) + return (char*)NullErr; + sv_setpv(sv, (const char *)buf8.PtrZ()); + SvUTF8_on(sv); + CleanupStack::PopAndDestroy(textResolver); + return SvPV_nolen(sv); + } + EXPORT_C void symbian_sleep_usec(const long usec) + { + User::After((TTimeIntervalMicroSeconds32) usec); + } +#define PERL_SYMBIAN_CLK_TCK 100 + EXPORT_C int symbian_get_cpu_time(long* sec, long* usec) + { + // The RThread().GetCpuTime() does not seem to work? + // (it always returns KErrNotSupported) + // TTimeIntervalMicroSeconds ti; + // TInt err = me.GetCpuTime(ti); + dTHX; + TInt periodus; /* tick period in microseconds */ + if (HAL::Get(HALData::ESystemTickPeriod, periodus) != KErrNone) + return -1; + TUint tick = User::TickCount(); + if (PL_timesbase.tms_utime == 0) { + PL_timesbase.tms_utime = tick; + PL_clocktick = PERL_SYMBIAN_CLK_TCK; + } + tick -= PL_timesbase.tms_utime; + TInt64 tickus = TInt64(tick) * TInt64(periodus); + TInt64 tmps = tickus / 1000000; + if (sec) *sec = tmps.Low(); + if (usec) *usec = tickus.Low() - tmps.Low() * 1000000; + return 0; + } + EXPORT_C int symbian_usleep(unsigned int usec) + { + if (usec >= 1000000) { + errno = EINVAL; + return -1; + } + symbian_sleep_usec((const long) usec); + return 0; + } +#define SEC_USEC_TO_CLK_TCK(s, u) \ + (((s) * PERL_SYMBIAN_CLK_TCK) + (u / (1000000 / PERL_SYMBIAN_CLK_TCK))) + EXPORT_C clock_t symbian_times(struct tms *tmsbuf) + { + long s, u; + if (symbian_get_cpu_time(&s, &u) == -1) { + errno = EINVAL; + return -1; + } else { + tmsbuf->tms_utime = SEC_USEC_TO_CLK_TCK(s, u); + tmsbuf->tms_stime = 0; + tmsbuf->tms_cutime = 0; + tmsbuf->tms_cstime = 0; + return tmsbuf->tms_utime; + } + } + class CE32ProcessWait : public CActive + { + public: + CE32ProcessWait() : CActive(EPriorityStandard) { + CActiveScheduler::Add(this); + } +#ifdef __WINS__ + TInt Wait(RThread& aProcess) +#else + TInt Wait(RProcess& aProcess) +#endif + { + aProcess.Logon(iStatus); + aProcess.Resume(); + SetActive(); + CActiveScheduler::Start(); + return iStatus.Int(); + } + private: + void DoCancel() {;} + void RunL() { + CActiveScheduler::Stop(); + } + CActiveSchedulerWait iWait; + }; + class CSpawnIoRedirect : public CBase + { + public: + CSpawnIoRedirect(); + // NOTE: there is no real implementation of I/O redirection yet. + protected: + private: + }; + CSpawnIoRedirect::CSpawnIoRedirect() + { + } + typedef enum { + ESpawnNone = 0x00000000, + ESpawnWait = 0x00000001 + } TSpawnFlag; + static int symbian_spawn(const TDesC& aFilename, + const TDesC& aCommand, + const TSpawnFlag aFlag, + const CSpawnIoRedirect& aIoRedirect) { + TInt error = KErrNone; +#ifdef __WINS__ + const TInt KStackSize = 0x1000; + const TInt KHeapMin = 0x1000; + const TInt KHeapMax = 0x100000; + RThread proc; + RLibrary lib; + HBufC* command = aCommand.Alloc(); + error = lib.Load(aFilename); + if (error == KErrNone) { + TThreadFunction func = (TThreadFunction)(lib.Lookup(1)); + if (func) + error = proc.Create(aFilename, + func, + KStackSize, + (TAny*)command, + &lib, + RThread().Heap(), + KHeapMin, + KHeapMax, + EOwnerProcess); + else + error = KErrNotFound; + lib.Close(); + } + else + delete command; +#else + RProcess proc; + error = proc.Create(aFilename, aCommand); +#endif + if (error == KErrNone) { + if ((TInt)aFlag & (TInt)ESpawnWait) { + CE32ProcessWait* w = new CE32ProcessWait(); + if (w) { + error = w->Wait(proc); + delete w; + } else + error = KErrNoMemory; + } else + proc.Resume(); + proc.Close(); + } + return error; + } + static int symbian_spawner(const char *command, TSpawnFlag aFlags) + { + TBuf aFilename; + TBuf aCommand; + TSpawnFlag aSpawnFlags = ESpawnWait; + CSpawnIoRedirect iord; + char *p = (char*)command; + + // The recognized syntax is: "cmd [args] [&]". Since one + // cannot pass more than (an argv[0] and) an argv[1] to a + // Symbian process anyway, not much is done to the cmd or + // the args, only backslash quoting. + + // Strip leading whitespace. + while (*p && isspace(*p)) p++; + if (*p) { + // Build argv[0]. + while (*p && !isspace(*p) && *p != '&') { + if (*p == '\\') { + if (p[1]) { + aFilename.Append(p[1]); + p++; + } + + } + else + aFilename.Append(*p); + p++; + } + + if (*p) { + // Skip whitespace between argv[0] and argv[1]. + while(*p && isspace(*p)) p++; + // Build argv[1]. + if (*p) { + char *a = p; + char *b = p + 1; + + while (*b) b++; + if (isspace(b[-1])) { + b--; + while (b > a && isspace(*b)) b--; + b++; + } + if (b > a && b[-1] == '&') { + // Parse backgrounding in any case, + // but turn it off only if wanted. + if ((aFlags & ESpawnWait)) + aSpawnFlags = + (TSpawnFlag) (aSpawnFlags & ~ESpawnWait); + b--; + if (isspace(b[-1])) { + b--; + while (b > a && isspace(*b)) b--; + b++; + } + } + for (p = a; p < b; p++) { + if (*p == '\\') { + if (p[1]) + aCommand.Append(p[1]); + p++; + } + else + aCommand.Append(*p); + } + } + // NOTE: I/O redirection is not yet done. + // Implementing that may require a separate server. + } + } + int spawned = symbian_spawn(aFilename, aCommand, aSpawnFlags, iord); + return spawned == KErrNone ? 0 : -1; + } + EXPORT_C int symbian_do_spawn(const char *command) + { + return symbian_spawner(command, ESpawnWait); + } + EXPORT_C int symbian_do_spawn_nowait(const char *command) + { + return symbian_spawner(command, ESpawnNone); + } + EXPORT_C int symbian_do_aspawn(void* vreally, void* vmark, void* sp) + { + return -1; + } +} + diff --git a/symbian/symbianish.h b/symbian/symbianish.h new file mode 100644 index 0000000..1aebaf1 --- /dev/null +++ b/symbian/symbianish.h @@ -0,0 +1,209 @@ +/* + * symbianish.h + * + * Copyright (c) Nokia 2004-2005. All rights reserved. + * This code is licensed under the same terms as Perl itself. + * + */ + +#include "symbian/symbian_port.h" + +/* + * The following symbols are defined if your operating system supports + * functions by that name. All Unixes I know of support them, thus they + * are not checked by the configuration script, but are directly defined + * here. + */ + +#ifndef PERL_MICRO + +/* HAS_IOCTL: + * This symbol, if defined, indicates that the ioctl() routine is + * available to set I/O characteristics + */ +#define HAS_IOCTL / **/ + +/* HAS_UTIME: + * This symbol, if defined, indicates that the routine utime() is + * available to update the access and modification times of files. + */ +/* #define HAS_UTIME / **/ + +/* HAS_GROUP + * This symbol, if defined, indicates that the getgrnam() and + * getgrgid() routines are available to get group entries. + * The getgrent() has a separate definition, HAS_GETGRENT. + */ +#undef HAS_GROUP /**/ + +/* HAS_PASSWD + * This symbol, if defined, indicates that the getpwnam() and + * getpwuid() routines are available to get password entries. + * The getpwent() has a separate definition, HAS_GETPWENT. + */ +#undef HAS_PASSWD /**/ + +#undef HAS_KILL +#undef HAS_WAIT + +#endif /* !PERL_MICRO */ + +/* USEMYBINMODE + * This symbol, if defined, indicates that the program should + * use the routine my_binmode(FILE *fp, char iotype) to insure + * that a file is in "binary" mode -- that is, that no translation + * of bytes occurs on read or write operations. + */ +#undef USEMYBINMODE + +/* Stat_t: + * This symbol holds the type used to declare buffers for information + * returned by stat(). It's usually just struct stat. It may be necessary + * to include and to get any typedef'ed + * information. + */ +#define Stat_t struct stat + +/* USE_STAT_RDEV: + * This symbol is defined if this system has a stat structure declaring + * st_rdev + */ +#define USE_STAT_RDEV /**/ + +/* ACME_MESS: + * This symbol, if defined, indicates that error messages should be + * should be generated in a format that allows the use of the Acme + * GUI/editor's autofind feature. + */ +#undef ACME_MESS /**/ + +/* UNLINK_ALL_VERSIONS: + * This symbol, if defined, indicates that the program should arrange + * to remove all versions of a file if unlink() is called. This is + * probably only relevant for VMS. + */ +/* #define UNLINK_ALL_VERSIONS / **/ + +/* VMS: + * This symbol, if defined, indicates that the program is running under + * VMS. It is currently automatically set by cpps running under VMS, + * and is included here for completeness only. + */ +/* #define VMS / **/ + +/* ALTERNATE_SHEBANG: + * This symbol, if defined, contains a "magic" string which may be used + * as the first line of a Perl program designed to be executed directly + * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG + * begins with a character other then #, then Perl will only treat + * it as a command line if it finds the string "perl" in the first + * word; otherwise it's treated as the first line of code in the script. + * (IOW, Perl won't hand off to another interpreter via an alternate + * shebang sequence that might be legal Perl code.) + */ +/* #define ALTERNATE_SHEBANG "#!" / **/ + +#include +#define ABORT() abort() + +/* + * fwrite1() should be a routine with the same calling sequence as fwrite(), + * but which outputs all of the bytes requested as a single stream (unlike + * fwrite() itself, which on some systems outputs several distinct records + * if the number_of_items parameter is >1). + */ +#define fwrite1 fwrite + +#define Stat(fname,bufptr) stat((fname),(bufptr)) +#define Fstat(fd,bufptr) fstat((fd),(bufptr)) +#define Fflush(fp) fflush(fp) +#define Mkdir(path,mode) mkdir((path),(mode)) + +#ifndef PERL_SYS_TERM +#define PERL_SYS_TERM() OP_REFCNT_TERM; MALLOC_TERM; CloseSTDLIB(); +#endif + +#define BIT_BUCKET "NUL:" + +#define dXSUB_SYS + +#define NO_ENVIRON_ARRAY + +int kill(pid_t pid, int signo); +pid_t wait(int *status); + +#ifdef PERL_GLOBAL_STRUCT_PRIVATE +# undef PERL_GET_VARS +# undef PERL_SET_VARS +# undef PERL_UNSET_VARS +# define PERL_GET_VARS() symbian_get_vars() +# define PERL_SET_VARS(v) symbian_set_vars(v) +# define PERL_UNSET_VARS(v) symbian_unset_vars() +#endif /* #ifdef PERL_GLOBAL_STRUCT_PRIVATE */ + +#undef PERL_EXPORT_C +#define PERL_EXPORT_C EXPORT_C /* for perlio.h */ +#define PERL_CALLCONV EXPORT_C /* for prototype.h */ +#undef PERL_XS_EXPORT_C +#define PERL_XS_EXPORT_C EXPORT_C + +#ifndef PERL_CORE +#define PERL_CORE /* for WINS builds under VC */ +#endif + +#ifdef USE_PERLIO +#define PERL_NEED_APPCTX /* need storing the PerlBase* */ +#define PERLIO_STD_SPECIAL +#define PERLIO_STD_IN(f, b, n) symbian_read_stdin(f, b, n) +#define PERLIO_STD_OUT(f, b, n) symbian_write_stdout(f, b, n) +/* The console (the STD*) streams are seen by Perl in UTF-8. */ +#define PERL_SYMBIAN_CONSOLE_UTF8 + +#endif + +#undef Strerror +#undef strerror +#define Strerror(eno) ((eno) < 0 ? symbian_get_error_string(eno) : strerror(eno)) + +#define PERL_NEED_TIMESBASE + +#define times(b) symbian_times(b) +#define usleep(u) symbian_usleep(u) + +#define PERL_SYS_INIT(c, v) symbian_sys_init(c, v) + +#ifdef __SERIES60_1X__ +# error "Unfortunately Perl does not work in S60 1.2 (see FAQ-0929)" +#endif + +#ifdef _MSC_VER + +/* The Symbian SDK insists on the /W4 flag for Visual C. + * The Perl sources are not _that_ clean (Perl builds for Win32 use + * the /W3 flag, and gcc builds always use -Wall, so the sources are + * quite clean). To avoid a flood of warnings let's shut up most + * (for VC 6.0 SP 5). */ + +#pragma warning(disable: 4054) /* function pointer to data pointer */ +#pragma warning(disable: 4055) /* data pointer to function pointer */ +#pragma warning(disable: 4100) /* unreferenced formal parameter */ +#pragma warning(disable: 4101) /* unreferenced local variable */ +#pragma warning(disable: 4102) /* unreferenced label */ +#pragma warning(disable: 4113) /* prototype difference */ +#pragma warning(disable: 4127) /* conditional expression is constant */ +#pragma warning(disable: 4132) /* const object should be initialized */ +#pragma warning(disable: 4133) /* incompatible types */ +#pragma warning(disable: 4189) /* initialized but not referenced */ +#pragma warning(disable: 4244) /* conversion from ... possible loss ... */ +#pragma warning(disable: 4245) /* signed/unsigned char */ +#pragma warning(disable: 4310) /* cast truncates constant value */ +#pragma warning(disable: 4505) /* function has been removed */ +#pragma warning(disable: 4510) /* default constructor could not ... */ +#pragma warning(disable: 4610) /* struct ... can never be instantiated */ +#pragma warning(disable: 4701) /* used without having been initialized */ +#pragma warning(disable: 4702) /* unreachable code */ +#pragma warning(disable: 4706) /* assignment within conditional */ +#pragma warning(disable: 4761) /* integral size mismatch */ + +#endif /* _MSC_VER */ + diff --git a/symbian/uid.pl b/symbian/uid.pl new file mode 100644 index 0000000..6eae8a9 --- /dev/null +++ b/symbian/uid.pl @@ -0,0 +1 @@ +0x102015F3 diff --git a/symbian/version.pl b/symbian/version.pl new file mode 100644 index 0000000..c8bb82e --- /dev/null +++ b/symbian/version.pl @@ -0,0 +1,22 @@ +use strict; + +my %VERSION; + +if (open(PATCHLEVEL_H, "patchlevel.h")) { + while () { + if (/#define\s+PERL_(REVISION|VERSION|SUBVERSION)\s+(\d+)/) { + $VERSION{$1} = $2; + } + } + close PATCHLEVEL_H; +} else { + die "$0: patchlevel.h: $!\n"; +} + +die "$0: Perl release looks funny.\n" + unless (defined $VERSION{REVISION} && $VERSION{REVISION} == 5 && + defined $VERSION{VERSION} && $VERSION{VERSION} >= 8 && + defined $VERSION{SUBVERSION}); + + +\%VERSION; diff --git a/symbian/xsbuild.pl b/symbian/xsbuild.pl new file mode 100644 index 0000000..ff743bd --- /dev/null +++ b/symbian/xsbuild.pl @@ -0,0 +1,861 @@ +#!/usr/bin/perl -w + +use strict; + +use Getopt::Long; +use File::Basename; +use Cwd; + +do "sanity.pl"; + +my $CoreBuild = -d "ext" && -f "perl.h" && -d "symbian" && -f "perl.c"; + +my $SymbianVersion = $ENV{XSBUILD_SYMBIAN_VERSION}; +my $PerlVersion = $ENV{XSBUILD_PERL_VERSION}; +my $CSuffix = '.c'; +my $CPlusPlus; +my $Config; +my $Build; +my $Clean; +my $DistClean; +my $Sis; + +sub usage { + die <<__EOF__; +$0: Usage: $0 [--symbian=version] [--perl=version] + [--csuffix=csuffix] [--cplusplus] + [--win=win] [--arm=arm] + [--config|--build|--clean|--distclean|--sis] ext +__EOF__ +} + +my $CWD; +my $SDK; +my $VERSION; +my $R_V_SV; +my $PERLSDK; +my $WIN; +my $ARM; +my $HOME = getcwd(); + +if ( !defined $PerlVersion && $0 =~ m:\\symbian\\perl\\(.+)\\bin\\xsbuild.pl:i ) +{ + $PerlVersion = $1; +} + +if ( !defined $SymbianVersion) { + ($SymbianVersion) = ($ENV{PATH} =~ m!C:\\Symbian\\(.+?)\\!i); +} + +my $S60SDK; + +if ($CoreBuild) { + unshift @INC, "symbian"; + do "sanity.pl"; + my %VERSION = %{ do "version.pl" }; + $SDK = do "sdk.pl"; + $VERSION = "$VERSION{REVISION}$VERSION{VERSION}$VERSION{SUBVERSION}"; + $R_V_SV = "$VERSION{REVISION}.$VERSION{VERSION}.$VERSION{SUBVERSION}"; + $HOME = do "cwd.pl"; + $SymbianVersion = $1 if $SDK =~ m:\\Symbian\\([^\\]+):; + $PerlVersion = $R_V_SV; + $S60SDK = $ENV{S60SDK}; # from sdk.pl +} + +usage() + unless GetOptions( + 'symbian=s' => \$SymbianVersion, + 'perl=s' => \$PerlVersion, + 'csuffix=s' => \$CSuffix, + 'cplusplus' => \$CPlusPlus, + 'win=s' => \$WIN, + 'arm=s' => \$ARM, + 'config' => \$Config, + 'build' => \$Build, + 'clean' => \$Clean, + 'distclean' => \$DistClean, + 'sis' => \$Sis + ); + +usage() unless @ARGV; + +$CSuffix = '.cpp' if $CPlusPlus; +$Build = !( $Config || $Clean || $DistClean ) || $Sis unless defined $Build; + +die "$0: Symbian version undefined\n" unless defined $SymbianVersion; + +$SymbianVersion =~ s:/:\\:g; + +die "$0: Symbian version '$SymbianVersion' not found\n" + unless -d "\\Symbian\\$SymbianVersion"; + +die "$0: Perl version undefined\n" unless defined $PerlVersion; + +die "$0: Perl version '$PerlVersion' not found\n" + if !$CoreBuild && !-d "\\Symbian\\Perl\\$PerlVersion"; + +print "Configuring with Symbian $SymbianVersion and Perl $PerlVersion...\n"; + +$SDK = "\\Symbian\\$SymbianVersion" unless defined $SDK; +$PERLSDK = "\\Symbian\\Perl\\$PerlVersion"; + +$R_V_SV = $PerlVersion; + +$VERSION =~ tr/.//d; + +$ENV{SDK} = $SDK; # For the Errno extension +$ENV{CROSS} = 1; # For the Encode extension + +my $UREL = $ENV{UREL}; # from sdk.pl +$UREL =~ s/-ARM-/$ARM/; +my $UARM = $ENV{UARM}; # from sdk.pl +my $SRCDBG = $UARM eq 'udeb' ? "SRCDBG" : ""; + +my %CONF; +my %EXTCFG; + +sub write_bld_inf { + my ($base) = @_; + print "\tbld.inf\n"; + open( BLD_INF, ">bld.inf" ) or die "$0: bld.inf: $!\n"; + print BLD_INF <<__EOF__; +PRJ_MMPFILES +$base.mmp +PRJ_PLATFORMS +$WIN $ARM +__EOF__ + close(BLD_INF); +} + +sub system_echo { + my $cmd = shift; + print "xsbuild: ", $cmd, "\n"; + return system($cmd); +} + +sub run_PL { + my ( $PL, $dir, $file ) = @_; + if ( defined $file ) { + print "\t(Running $dir\\$PL to create $file)\n"; + unlink($file); + } + else { + print "\t(Running $dir\\$PL)\n"; + } + my $cmd; + if ($CoreBuild) { + # Problem: the Config.pm we have in $HOME\\lib carries the + # version number of the Perl we are building, while the Perl + # we are running might have some other version. Solution: + # temporarily replace the Config.pm with a patched version. + my $V = sprintf "%vd", $^V; + unlink("$HOME\\lib\\Config.pm.bak"); + system_echo("perl -pi.bak -e \"s:\\Q$R_V_SV:$V:\" $HOME\\lib\\Config.pm"); + } + system_echo("perl -I$HOME\\lib -I$HOME\\xlib\\symbian $PL") == 0 + or warn "$0: $PL failed.\n"; + if ($CoreBuild) { + system_echo("copy $HOME\\lib\\Config.pm.bak $HOME\\lib\\Config.pm"); + } + if ( defined $file ) { -s $file or die "$0: No $file created.\n" } +} + +sub read_old_multi { + my ( $conf, $k ) = @_; + push @{ $conf->{$k} }, split( ' ', $1 ) if /^$k\s(.+)$/; +} + +sub uniquefy_filenames { + my $b = []; + my %c = (); + for my $i (@{$_[0]}) { + $i =~ s!/!\\!g; + $i = lc $i if $i =~ m!\\!; + $i =~ s!^c:!!; + push @$b, $i unless $c{$i}++; + } + return $b; +} + +sub read_mmp { + my ( $conf, $mmp ) = @_; + if ( -r $mmp && open( MMP, "<$mmp" ) ) { + print "\tReading $mmp...\n"; + while () { + chomp; + $conf->{TARGET} = $1 if /^TARGET\s+(.+)$/; + $conf->{TARGETPATH} = $1 if /^TARGETPATH\s+(.+)$/; + $conf->{EXTVERSION} = $1 if /^EXTVERSION\s+(.+)$/; + read_old_multi( $conf, "SOURCE" ); + read_old_multi( $conf, "SOURCEPATH" ); + read_old_multi( $conf, "USERINCLUDE" ); + read_old_multi( $conf, "SYSTEMINCLUDE" ); + read_old_multi( $conf, "LIBRARY" ); + read_old_multi( $conf, "MACRO" ); + } + close(MMP); + } +} + +sub write_mmp { + my ( $base, $userinclude, @src ) = @_; + + print "\t$base.mmp\n"; + $CONF{TARGET} = "$base.dll"; + $CONF{TARGETPATH} = "\\System\\Libs\\Perl\\$R_V_SV"; + $CONF{SOURCE} = [@src]; + $CONF{SOURCEPATH} = [ $CWD, $HOME ]; + $CONF{USERINCLUDE} = [ $CWD, $HOME ]; + $CONF{SYSTEMINCLUDE} = ["$PERLSDK\\include"] unless $CoreBuild; + $CONF{SYSTEMINCLUDE} = [ $HOME ] if $CoreBuild; + $CONF{LIBRARY} = []; + $CONF{MACRO} = []; + read_mmp( \%CONF, "_init.mmp" ); + read_mmp( \%CONF, "$base.mmp" ); + + for my $ui ( @{$userinclude} ) { + $ui =~ s!/!\\!g; + if ( $ui =~ m!^(?:[CD]:)?\\! ) { + push @{ $CONF{USERINCLUDE} }, $ui; + } + else { + push @{ $CONF{USERINCLUDE} }, "$HOME\\$ui"; + } + } + push @{ $CONF{SYSTEMINCLUDE} }, "\\epoc32\\include"; + push @{ $CONF{SYSTEMINCLUDE} }, "\\epoc32\\include\\libc"; + push @{ $CONF{LIBRARY} }, "euser.lib"; + push @{ $CONF{LIBRARY} }, "estlib.lib"; + push @{ $CONF{LIBRARY} }, "perl$VERSION.lib"; + push @{ $CONF{MACRO} }, "SYMBIAN" unless $CoreBuild; + push @{ $CONF{MACRO} }, "PERL_EXT" if $CoreBuild; + push @{ $CONF{MACRO} }, "MULTIPLICITY"; + push @{ $CONF{MACRO} }, "PERL_IMPLICIT_CONTEXT"; + push @{ $CONF{MACRO} }, "PERL_GLOBAL_STRUCT"; + push @{ $CONF{MACRO} }, "PERL_GLOBAL_STRUCT_PRIVATE"; + + for my $u (qw(SOURCE SOURCEPATH SYSTEMINCLUDE USERINCLUDE LIBRARY MACRO)) { + $CONF{$u} = uniquefy_filenames( $CONF{$u} ); + } + open( BASE_MMP, ">$base.mmp" ) or die "$0: $base.mmp: $!\n"; + + print BASE_MMP <<__EOF__; +TARGET $CONF{TARGET} +TARGETTYPE dll +TARGETPATH $CONF{TARGETPATH} +SOURCE @{$CONF{SOURCE}} +$SRCDBG +__EOF__ + for my $u (qw(SOURCEPATH SYSTEMINCLUDE USERINCLUDE)) { + for my $v ( @{ $CONF{$u} } ) { + print BASE_MMP "$u\t$v\n"; + } + } + # OPTION does not work in MMPs for pre-2.0 SDKs? + print BASE_MMP <<__EOF__; +LIBRARY @{$CONF{LIBRARY}} +MACRO @{$CONF{MACRO}} +// OPTION MSVC /P +// OPTION GCC -E +__EOF__ + close(BASE_MMP); + +} + +sub write_makefile { + my ( $base, $build ) = @_; + + print "\tMakefile\n"; + + my $windef1 = "$SDK\\Epoc32\\Build$CWD\\$base\\$WIN\\$base.def"; + my $windef2 = "..\\BWINS\\${base}u.def"; + my $armdef1 = "$SDK\\Epoc32\\Build$CWD\\$base\\$ARM\\$base.def"; + my $armdef2 = "..\\BMARM\\${base}u.def"; + + my $wrap = $SDK && $S60SDK eq '1.2' && $SDK !~ /_CW$/; + my $ABLD = $wrap ? 'perl b.pl' : 'abld'; + + open( MAKEFILE, ">Makefile" ) or die "$0: Makefile: $!\n"; + print MAKEFILE <<__EOF__; +WIN = $WIN +ARM = $ARM +ABLD = $ABLD + +all: build freeze + +sis: build_arm freeze_arm + +build: abld.bat build_win build_arm + +abld.bat: + bldmake bldfiles + +build_win: abld.bat + bldmake bldfiles + \$(ABLD) build \$(WIN) udeb + +build_arm: abld.bat + bldmake bldfiles + \$(ABLD) build \$(ARM) $UARM + +win: build_win freeze_win + +arm: build_arm freeze_arm + +freeze: freeze_win freeze_arm + +freeze_win: + bldmake bldfiles + \$(ABLD) freeze \$(WIN) $base + +freeze_arm: + bldmake bldfiles + \$(ABLD) freeze \$(ARM) $base + +defrost: defrost_win defrost_arm + +defrost_win: + -del /f $windef1 + -del /f $windef2 + +defrost_arm: + -del /f $armdef1 + -del /f $armdef2 + +clean: clean_win clean_arm + +clean_win: + \$(ABLD) clean \$(WIN) + +clean_arm: + \$(ABLD) clean \$(ARM) + +realclean: clean realclean_win realclean_arm + -del /f _init.c b.pl + -del /f $base.c $base.mmp + +realclean_win: + \$(ABLD) reallyclean \$(WIN) + +realclean_arm: + \$(ABLD) reallyclean \$(ARM) + +distclean: defrost realclean + -rmdir ..\\BWINS ..\\BMARM + -del /f const-c.inc const-xs.inc + -del /f Makefile abld.bat bld.inf +__EOF__ + close(MAKEFILE); + if ($wrap) { + if(open(B,">b.pl")) { + print B <<'__EOF__'; +# abld.pl wrapper. + +# nmake doesn't like MFLAGS and MAKEFLAGS being set to -w and w. +delete $ENV{MFLAGS}; +delete $ENV{MAKEFLAGS}; + +print "abld @ARGV\n"; +system("abld @ARGV"); +__EOF__ + close(B); + } else { + warn "$0: failed to create b.pl: $!\n"; + } + } +} + +sub update_dir { + print "[chdir from ", getcwd(), " to "; + chdir(shift) or return; + update_cwd(); + print getcwd(), "]\n"; +} + +sub xsconfig { + my ( $ext, $dir ) = @_; + print "Configuring for $ext, directory $dir...\n"; + my $extu = $CoreBuild ? "$HOME\\lib\\ExtUtils" : "$PERLSDK\\lib\\ExtUtils"; + update_dir($dir) or die "$0: chdir '$dir': $!\n"; + my $build = dirname($ext); + my $base = basename($ext); + my $basexs = "$base.xs"; + my $basepm = "$base.pm"; + my $basec = "$base$CSuffix"; + my $extdir = "."; + if ( $dir =~ m:^ext\\(.+): ) { + $extdir = $1; + } + elsif ( $dir ne "." ) { + $extdir = $dir; + } + my $extdirdir = dirname($extdir); + my $targetroot = "\\System\\Libs\\Perl\\$R_V_SV"; + write_bld_inf($base) if -f $basexs; + + my %src; + $src{$basec}++; + + $extdirdir = $extdirdir eq "." ? "" : "$extdirdir\\"; + + my %lst; + $lst{"$UREL\\$base.dll"} = + "$targetroot\\$ARM-symbian\\$base.dll" + if -f $basexs; + $lst{"$dir\\$base.pm"} = "$targetroot\\$extdirdir$base.pm" + if -f $basepm && $base ne 'XSLoader'; + + my %incdir; + my $ran_PL; + if ( -d 'lib' ) { + use File::Find; + my @found; + find( sub { push @found, $File::Find::name if -f $_ }, 'lib' ); + for my $found (@found) { + my ($short) = ( $found =~ m/^lib.(.+)/ ); + $short =~ s!/!\\!g; + $found =~ s!/!\\!g; + $lst{"$dir\\$found"} = "$targetroot\\$short"; + } + } + if ( my @pm = glob("*.pm */*.pm") ) { + for my $pm (@pm) { + next if $pm =~ m:^t/:; + $pm =~ s:/:\\:g; + $lst{"$dir\\$pm"} = "$targetroot\\$extdirdir$pm"; + } + } + if ( my @c = glob("*.c *.cpp */*.c */*.cpp") ) { + for my $c (@c) { + $c =~ s:/:\\:g; + $src{$c}++; + } + } + if ( my @h = glob("*.h */*.h") ) { + for my $h (@h) { + $h =~ s:/:\\:g; + $h = dirname($h); + $incdir{"$dir\\$h"}++ unless $h eq "."; + } + } + if ( exists $EXTCFG{$ext} ) { + for my $cfg ( @{ $EXTCFG{$ext} } ) { + if ( $cfg =~ /^([-+])?(.+\.(c|cpp|h))$/ ) { + my $o = defined $1 ? $1 : '+'; + my $f = $2; + $f =~ s:/:\\:g; + for my $f ( glob($f) ) { + if ( $o eq '+' ) { + warn "$0: no source file $dir\\$f\n" unless -f $f; + $src{$f}++ unless $cfg =~ /\.h$/; + if ( $f =~ m:^(.+)\\[^\\]+$: ) { + $incdir{$1}++; + } + } + elsif ( $o eq '-' ) { + delete $src{$f}; + } + } + } + if ( $cfg =~ /^([-+])?(.+\.(pm|pl|inc))$/ ) { + my $o = defined $1 ? $1 : '+'; + my $f = $2; + $f =~ s:/:\\:g; + for my $f ( glob($f) ) { + if ( $o eq '+' ) { + warn "$0: no Perl file $dir\\$f\n" unless -f $f; + $lst{"$dir\\$f"} = "$targetroot\\$extdir\\$f"; + } + elsif ( $o eq '-' ) { + delete $lst{"$dir\\$f"}; + } + } + } + if ( $cfg eq 'CONST' && !$ran_PL++ ) { + run_PL( "Makefile.PL", $dir, "const-xs.inc" ); + } + } + } + unless ( $ran_PL++ ) { + run_PL( "Makefile.PL", $dir ) if -f "Makefile.PL"; + } + if ( $dir eq "ext\\Errno" ) { + run_PL( "Errno_pm.PL", $dir, "Errno.pm" ); + $lst{"$dir\\Errno.pm"} = "$targetroot\\Errno.pm"; + } + elsif ( $dir eq "ext\\Devel\\PPPort" ) { + run_PL( "ppport_h.PL", $dir, "ppport.h" ); + } + elsif ( $dir eq "ext\\DynaLoader" ) { + run_PL( "XSLoader_pm.PL", $dir, "XSLoader.pm" ); + $lst{"ext\\DynaLoader\\XSLoader.pm"} = "$targetroot\\XSLoader.pm"; + } + elsif ( $dir eq "ext\\Encode" ) { + system_echo("perl bin\\enc2xs -Q -O -o def_t.c -f def_t.fnm") == 0 + or die "$0: running enc2xs failed: $!\n"; + } + + my @lst = sort keys %lst; + + read_mmp( \%CONF, "_init.mmp" ); + read_mmp( \%CONF, "$base.mmp" ); + + if ( -f $basexs ) { + my %MM; # MakeMaker results + my @MM = qw(VERSION XS_VERSION); + if ( -f "Makefile" ) { + print "\tReading MakeMaker Makefile...\n"; + if ( open( MAKEFILE, "Makefile" ) ) { + while () { + for my $m (@MM) { + if (m!^$m = (.+)!) { + $MM{$m} = $1; + print "\t$m = $1\n"; + } + } + } + close(MAKEFILE); + } + else { + warn "$0: Makefile: $!"; + } + print "\tDeleting MakeMaker Makefile.\n"; + unlink("Makefile"); + } + + unlink($basec); + print "\t$basec\n"; + if ( defined $CONF{EXTVERSION} ) { + my $EXTVERSION = $CONF{EXTVERSION}; + print "\tUsing $EXTVERSION for version...\n"; + $MM{VERSION} = $MM{XS_VERSION} = $EXTVERSION; + } + die "VERSION or XS_VERSION undefined\n" + unless defined $MM{VERSION} && defined $MM{XS_VERSION}; + if ( open( BASE_C, ">$basec" ) ) { + print BASE_C <<__EOF__; +#ifndef VERSION +#define VERSION "$MM{VERSION}" +#endif +#ifndef XS_VERSION +#define XS_VERSION "$MM{XS_VERSION}" +#endif +__EOF__ + close(BASE_C); + } + else { + warn "$0: $basec: $!"; + } + unless ( + system( +"perl -I$PERLSDK\\lib $extu\\xsubpp -C++ -csuffix .cpp -typemap $extu\\typemap -noprototypes $basexs >> $basec" + ) == 0 + && -s $basec + ) + { + die "$0: perl xsubpp failed: $!\n"; + } + + print "\t_init.c\n"; + open( _INIT_C, ">_init.c" ) or die "$!: _init.c: $!\n"; + print _INIT_C <<__EOF__; + #include "EXTERN.h" + #include "perl.h" + EXPORT_C void _init(void *handle) { + } +__EOF__ + close(_INIT_C); + + my @src = ( "_init.c", sort keys %src ); + + if ( $base eq "Encode" ) { # Currently unused. + for my $submf ( glob("*/Makefile") ) { + my $d = dirname($submf); + print "Configuring Encode::$d...\n"; + if ( open( SUBMF, $submf ) ) { + if ( update_dir($d) ) { + my @subsrc; + while () { + next if 1 .. /postamble/; + if (m!^(\w+_t)\.c : !) { + system( + "perl ..\\bin\\enc2xs -Q -o $1.c -f $1.fnm") + == 0 + or warn "$0: enc2xs: $!\n"; + push @subsrc, "$1.c"; + } + } + close(SUBMF); + unlink($submf); + my $subbase = $d; + $subbase =~ s!/!::!g; + write_mmp( $subbase, ["..\\Encode"], "$subbase.c", + @subsrc ); + write_makefile( $subbase, $build ); + write_bld_inf($subbase); + + unless ( + system( +"perl -I$HOME\\lib ..\\$extu\\xsubpp -C++ -csuffix .cpp -typemap ..\\$extu\\typemap -noprototypes $subbase.xs > $subbase.c" + ) == 0 + && -s "$subbase.c" + ) + { + die "$0: perl xsubpp failed: $!\n"; + } + update_dir(".."); + } + else { + warn "$0: chdir $d: $!\n"; + } + } + else { + warn "$0: $submf: $!"; + } + } + print "Configuring Encode...\n"; + } + + write_mmp( $base, [ keys %incdir ], @src ); + write_makefile( $base, $build ); + } + my $lstname = $ext; + $lstname =~ s:^ext\\::; + $lstname =~ s:\\:-:g; + print "\t$lstname.lst\n"; + my $lstout = + $CoreBuild ? "$HOME/symbian/$lstname.lst" : "$HOME/$lstname.lst"; + if ( open( my $lst, ">$lstout" ) ) { + for my $f (@lst) { print $lst qq["$f"-"!:$lst{$f}"\n] } + close($lst); + } + else { + die "$0: $lstout: $!\n"; + } + update_dir($HOME); +} + +sub update_cwd { + $CWD = getcwd(); + $CWD =~ s!^[CD]:!!i; + $CWD =~ s!/!\\!g; +} + +for my $ext (@ARGV) { + + $ext =~ s!::!\\!g; + $ext =~ s!/!\\!g; + + my $cfg; + + $cfg = $2 if $ext =~ s/(.+?),(.+)/$1/; + + my $dir; + + unless ( -e $ext ) { + if ( $ext =~ /\.xs$/ && !-f $ext ) { + if ( -f "ext\\$ext" ) { + $ext = "ext\\$ext"; + $dir = dirname($ext); + } + } + elsif ( !-d $ext ) { + if ( -d "ext\\$ext" ) { + $ext = "ext\\$ext"; + $dir = $ext; + } + } + $dir = "." unless defined $dir; + } + else { + if ( $ext =~ /\.xs$/ && -f $ext ) { + $ext = dirname($ext); + $dir = $ext; + } + elsif ( -d $ext ) { + $dir = $ext; + } + } + + if ( $ext eq "XSLoader" ) { + $ext = "ext\\XSLoader"; + } + if ( $ext eq "ext\\XSLoader" ) { + $dir = "ext\\DynaLoader"; + } + + $EXTCFG{$ext} = [ split( /,/, $cfg ) ] if defined $cfg; + + die "$0: no lib\\Config.pm\n" + if $CoreBuild && $Build && !-f "lib\\Config.pm"; + + if ($CoreBuild) { + open( my $cfg, "symbian/install.cfg" ) + or die "$0: symbian/install.cfg: $!\n"; + my $extdir = $dir; + $extdir =~ s:^ext\\::; + while (<$cfg>) { + next unless /^ext\s+(.+)/; + chomp; + my $ext = $1; + my @ext = split( ' ', $ext ); + $EXTCFG{"ext\\$ext[0]"} = [@ext]; + } + close($cfg); + } + + if ( $Config || $Build ) { + xsconfig( $ext, $dir ) or die "$0: xsconfig '$ext' failed\n"; + next if $Config; + } + + my $chdir = $ext eq "ext\\XSLoader" ? "ext\\DynaLoader" : $dir; + die "$0: no directory '$chdir'\n" unless -d $chdir; + update_dir($chdir) or die "$0: chdir '$chdir' failed: $!\n"; + + my %CONF; + + my @ext = split( /\\/, $ext ); + my $base = $ext[-1]; + + if ( $Clean || $DistClean ) { + print "Cleaning $ext...\n"; + unlink("bld.inf"); + unlink("$base.mmp"); + unlink("_init.c"); + unlink("const-c.inc"); + unlink("const-xs.inc"); + rmdir("..\\bmarm"); + } + + if ( $Build && $ext ne "ext\\XSLoader" && $ext ne "ext\\Errno" ) { + + # We compile the extension three (3) times. + # (1) Only the _init.c to get _init() as the ordinal 1 function in the DLL. + # (2) With the rest and the _init.c to get ordinals for the rest. + # (3) With an updated _init.c that carries the symbols from step (2). + + system("make clean"); + system("make defrost") == 0 or die "$0: make defrost failed\n"; + + my @TARGET; + + push @TARGET, 'sis' if $Sis; + + # Compile #1. + # Hide all but the _init.c. + print "\n*** $ext - Compile 1 of 3.\n\n"; + system( +"perl -pi.bak -e \"s:^SOURCE\\s+_init.c:SOURCE\\t_init.c // :\" $base.mmp" + ); + system("bldmake bldfiles"); + system("make @TARGET") == 0 or die "$0: make #1 failed\n"; + + # Compile #2. + # Reveal the rest again. + print "\n*** $ext - Compile 2 of 3.\n\n"; + system( +"perl -pi.bak -e \"s:^SOURCE\\t_init.c // :SOURCE\\t_init.c :\" $base.mmp" + ); + system("make @TARGET") == 0 or die "$0: make #2 failed\n"; + unlink("$base.mmp.bak"); + + open( _INIT_C, ">_init.c" ) or die "$0: _init.c: $!\n"; + print _INIT_C <<'__EOF__'; +#include "EXTERN.h" +#include "perl.h" + +/* This is a different but matching definition from in dl_symbian.xs. */ +typedef struct { + void* handle; + int error; + HV* symbols; +} PerlSymbianLibHandle; + +EXPORT_C void _init(void* handle) { +__EOF__ + + my %symbol; + my $def; + my $basef; + for my $f ("$SDK\\Epoc32\\Build$CWD\\$base\\WINS\\$base.def", + "..\\BMARM\\${base}u.def") { + print "\t($f - "; + if ( open( $def, $f ) ) { + print "OK)\n"; + $basef = $f; + last; + } else { + print "no)\n"; + } + } + unless (defined $basef) { + die "$0: failed to find .def for $base\n"; + } + while (<$def>) { + next while 1 .. /^EXPORTS/; + if (/^\s*(\w+) \@ (\d+) /) { + $symbol{$1} = $2; + } + } + close($def); + + my @symbol = sort keys %symbol; + if (@symbol) { + print _INIT_C <<'__EOF__'; + dTHX; + PerlSymbianLibHandle* h = (PerlSymbianLibHandle*)handle; + if (!h->symbols) + h->symbols = newHV(); + if (h->symbols) { +__EOF__ + for my $sym (@symbol) { + my $len = length($sym); + print _INIT_C <<__EOF__; + hv_store(h->symbols, "$sym", $len, newSViv($symbol{$sym}), 0); +__EOF__ + } + } + else { + die "$0: $basef: no exports found\n"; + } + + print _INIT_C <<'__EOF__'; + } +} +__EOF__ + close(_INIT_C); + + # Compile #3. This is for real. + print "\n*** $ext - Compile 3 of 3.\n\n"; + system("make @TARGET") == 0 or die "$0: make #3 failed\n"; + + } + elsif ( $Clean || $DistClean ) { + if ( $ext eq "ext\\Errno" ) { + unlink( "Errno.pm", "Makefile" ); + } + else { + if ( -f "Makefile" ) { + if ($Clean) { + system("make clean") == 0 or die "$0: make clean failed\n"; + } + elsif ($DistClean) { + system("make distclean") == 0 + or die "$0: make distclean failed\n"; + } + } + if ( $ext eq "ext\\Devel\\PPPort" ) { + unlink("ppport.h"); + } + } + my @B = glob("ext/BWINS ext/BMARM ext/*/BWINS ext/*/BMARM Makefile"); + rmdir(@B) if @B; + } + + update_dir($HOME); + +} # for my $ext + +exit(0); + diff --git a/taint.c b/taint.c index f21aedc..03bdedc 100644 --- a/taint.c +++ b/taint.c @@ -74,8 +74,8 @@ Perl_taint_env(pTHX) { SV** svp; MAGIC* mg; - const char** e; - static const char* misc_env[] = { + const char* const *e; + static const char* const misc_env[] = { "IFS", /* most shells' inter-field separators */ "CDPATH", /* ksh dain bramage #1 */ "ENV", /* ksh dain bramage #2 */ diff --git a/toke.c b/toke.c index cd2cfe5..d35227f 100644 --- a/toke.c +++ b/toke.c @@ -26,9 +26,12 @@ #define yychar (*PL_yycharp) #define yylval (*PL_yylvalp) -static char const ident_too_long[] = "Identifier too long"; -static char const c_without_g[] = "Use of /c modifier is meaningless without /g"; -static char const c_in_subst[] = "Use of /c modifier is meaningless in s///"; +static const char ident_too_long[] = + "Identifier too long"; +static const char c_without_g[] = + "Use of /c modifier is meaningless without /g"; +static const char c_in_subst[] = + "Use of /c modifier is meaningless in s///"; static void restore_rsfp(pTHX_ void *f); #ifndef PERL_NO_UTF16_FILTER @@ -76,7 +79,7 @@ static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); #define LEX_KNOWNEXT 0 #ifdef DEBUGGING -static char const* lex_state_names[] = { +static const char* const lex_state_names[] = { "KNOWNEXT", "FORMLINE", "INTERPCONST", @@ -199,7 +202,8 @@ enum token_type { TOKENTYPE_GVVAL }; -static struct debug_tokens { const int token, type; const char *name; } debug_tokens[] = +static struct debug_tokens { const int token, type; const char *name; } + const debug_tokens[] = { { ADDOP, TOKENTYPE_OPNUM, "ADDOP" }, { ANDAND, TOKENTYPE_NONE, "ANDAND" }, @@ -1167,6 +1171,7 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { + dVAR; ENTER; PL_lex_state = PL_sublex_info.super_state; @@ -1225,6 +1230,7 @@ S_sublex_push(pTHX) STATIC I32 S_sublex_done(pTHX) { + dVAR; if (!PL_lex_starts++) { SV *sv = newSVpvn("",0); if (SvUTF8(PL_linestr)) @@ -2271,7 +2277,7 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) } #ifdef DEBUGGING - static char const* exp_name[] = + static const char* const exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", "ATTRTERM", "TERMBLOCK", "TERMORDORDOR" }; @@ -2831,6 +2837,7 @@ Perl_yylex(pTHX) !instr(s,"indir") && instr(PL_origargv[0],"perl")) { + dVAR; char **newargv; *ipathend = '\0'; @@ -8939,7 +8946,7 @@ STATIC SV * S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type) { - dSP; + dVAR; dSP; HV *table = GvHV(PL_hintgv); /* ^H */ SV *res; SV **cvp; @@ -9285,6 +9292,7 @@ S_scan_pat(pTHX_ char *start, I32 type) STATIC char * S_scan_subst(pTHX_ char *start) { + dVAR; register char *s; register PMOP *pm; I32 first_start; @@ -10151,16 +10159,17 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) I32 shift; bool overflowed = FALSE; bool just_zero = TRUE; /* just plain 0 or binary number? */ - static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; - static char const* bases[5] = { "", "binary", "", "octal", - "hexadecimal" }; - static char const* Bases[5] = { "", "Binary", "", "Octal", - "Hexadecimal" }; - static char const *maxima[5] = { "", - "0b11111111111111111111111111111111", - "", - "037777777777", - "0xffffffff" }; + static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; + static const char* const bases[5] = + { "", "binary", "", "octal", "hexadecimal" }; + static const char* const Bases[5] = + { "", "Binary", "", "Octal", "Hexadecimal" }; + static const char* const maxima[5] = + { "", + "0b11111111111111111111111111111111", + "", + "037777777777", + "0xffffffff" }; const char *base, *Base, *max; /* check for hex */ diff --git a/universal.c b/universal.c index a90ba5d..e93a7c1 100644 --- a/universal.c +++ b/universal.c @@ -168,9 +168,9 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) #include "XSUB.h" -void XS_UNIVERSAL_isa(pTHX_ CV *cv); -void XS_UNIVERSAL_can(pTHX_ CV *cv); -void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); XS(XS_version_new); XS(XS_version_stringify); XS(XS_version_numify); diff --git a/utf8.c b/utf8.c index 4f41a97..20f94df 100644 --- a/utf8.c +++ b/utf8.c @@ -25,7 +25,8 @@ #define PERL_IN_UTF8_C #include "perl.h" -static char unees[] = "Malformed UTF-8 character (unexpected end of string)"; +static const char unees[] = + "Malformed UTF-8 character (unexpected end of string)"; /* =head1 Unicode Support @@ -1570,6 +1571,7 @@ Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp) SV* Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none) { + dVAR; SV* retval; SV* tokenbufsv = sv_newmortal(); dSP; @@ -1643,6 +1645,7 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits UV Perl_swash_fetch(pTHX_ SV *sv, const U8 *ptr, bool do_utf8) { + dVAR; HV* hv = (HV*)SvRV(sv); U32 klen; U32 off; @@ -1693,7 +1696,7 @@ Perl_swash_fetch(pTHX_ SV *sv, const U8 *ptr, bool do_utf8) if (hv == PL_last_swash_hv && klen == PL_last_swash_klen && - (!klen || memEQ(ptr, PL_last_swash_key, klen)) ) + (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) ) { tmps = PL_last_swash_tmps; slen = PL_last_swash_slen; diff --git a/utf8.h b/utf8.h index a8d440d..c87bbf2 100644 --- a/utf8.h +++ b/utf8.h @@ -42,7 +42,7 @@ EXTCONST unsigned char PL_utf8skip[]; #endif END_EXTERN_C -#define UTF8SKIP(s) PL_utf8skip[*(const U8*)s] +#define UTF8SKIP(s) PL_utf8skip[*(const U8*)(s)] /* Native character to iso-8859-1 */ #define NATIVE_TO_ASCII(ch) (ch) diff --git a/util.c b/util.c index fd5e041..5c1cdea 100644 --- a/util.c +++ b/util.c @@ -141,6 +141,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t Perl_safesysfree(Malloc_t where) { + dVAR; #ifdef PERL_IMPLICIT_SYS dTHX; #endif @@ -446,7 +447,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit && ((STRLEN)(bigend - big) == littlelen - 1) && (littlelen == 1 || (*big == *little && - memEQ(big, little, littlelen - 1)))) + memEQ((char *)big, (char *)little, littlelen - 1)))) return (char*)big; return Nullch; } @@ -729,6 +730,7 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) I32 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) { + dVAR; register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; while (len--) { @@ -986,7 +988,7 @@ SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); - static char dgd[] = " during global destruction.\n"; + static const char dgd[] = " during global destruction.\n"; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { @@ -1021,6 +1023,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) void Perl_write_to_stderr(pTHX_ const char* message, int msglen) { + dVAR; IO *io; MAGIC *mg; @@ -1072,6 +1075,7 @@ STATIC char * S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, I32* utf8) { + dVAR; char *message; if (pat) { @@ -1255,6 +1259,7 @@ Perl_croak(pTHX_ const char *pat, ...) void Perl_vwarn(pTHX_ const char* pat, va_list *args) { + dVAR; char *message; HV *stash; GV *gv; @@ -1334,7 +1339,7 @@ Perl_warn(pTHX_ const char *pat, ...) void Perl_warner_nocontext(U32 err, const char *pat, ...) { - dTHX; + dTHX; va_list args; va_start(args, pat); vwarner(err, pat, &args); @@ -1354,6 +1359,7 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { + dVAR; if (ckDEAD(err)) { SV *msv = vmess(pat, args); STRLEN msglen; @@ -1393,6 +1399,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) void Perl_my_setenv(pTHX_ const char *nam, const char *val) { + dVAR; #ifdef USE_ITHREADS /* only parent thread can modify process environment */ if (PL_curinterp == aTHX) @@ -1442,7 +1449,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) my_setenv_format(environ[i], nam, nlen, val, vlen); } else { # endif -# if defined(__CYGWIN__) || defined( EPOC) +# if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN) setenv(nam, val, 1); # else char *new_env; @@ -1467,6 +1474,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) void Perl_my_setenv(pTHX_ const char *nam, const char *val) { + dVAR; register char *envstr; const int nlen = strlen(nam); int vlen; @@ -1573,7 +1581,7 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len) register I32 tmp; while (len--) { - if (tmp = *a++ - *b++) + if ((tmp = *a++ - *b++)) return tmp; } return 0; @@ -2131,8 +2139,6 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #ifndef OS2 if (doexec) { #if !defined(HAS_FCNTL) || !defined(F_SETFD) - int fd; - #ifndef NOFILE #define NOFILE 20 #endif @@ -2246,6 +2252,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) void Perl_atfork_lock(void) { + dVAR; #if defined(USE_ITHREADS) /* locks must be held in locking order (if any) */ # ifdef MYMALLOC @@ -2259,6 +2266,7 @@ Perl_atfork_lock(void) void Perl_atfork_unlock(void) { + dVAR; #if defined(USE_ITHREADS) /* locks must be released in same order as in atfork_lock() */ # ifdef MYMALLOC @@ -2303,6 +2311,7 @@ Perl_dump_fds(pTHX_ char *s) PerlIO_printf(Perl_debug_log," %d",fd); } PerlIO_printf(Perl_debug_log,"\n"); + return; } #endif /* DUMP_FDS */ @@ -2351,6 +2360,7 @@ dup2(int oldfd, int newfd) Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { + dVAR; struct sigaction act, oact; #ifdef USE_ITHREADS @@ -2390,6 +2400,7 @@ Perl_rsignal_state(pTHX_ int signo) int Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) { + dVAR; struct sigaction act; #ifdef USE_ITHREADS @@ -2415,6 +2426,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) int Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) { + dVAR; #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) @@ -2438,19 +2450,18 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) return PerlProc_signal(signo, handler); } -static int sig_trapped; /* XXX signals are process-wide anyway, so we - ignore the implications of this for threading */ - static Signal_t sig_trap(int signo) { - sig_trapped++; + dVAR; + PL_sig_trapped++; } Sighandler_t Perl_rsignal_state(pTHX_ int signo) { + dVAR; Sighandler_t oldsig; #if defined(USE_ITHREADS) && !defined(WIN32) @@ -2459,10 +2470,10 @@ Perl_rsignal_state(pTHX_ int signo) return SIG_ERR; #endif - sig_trapped = 0; + PL_sig_trapped = 0; oldsig = PerlProc_signal(signo, sig_trap); PerlProc_signal(signo, oldsig); - if (sig_trapped) + if (PL_sig_trapped) PerlProc_kill(PerlProc_getpid(), signo); return oldsig; } @@ -2560,16 +2571,15 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { - I32 result; + I32 result = 0; if (!pid) return -1; #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) { - SV *sv; - SV** svp; char spid[TYPE_CHARS(IV)]; if (pid > 0) { + SV** svp; sprintf(spid, "%"IVdf, (IV)pid); svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); if (svp && *svp != &PL_sv_undef) { @@ -2583,8 +2593,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) hv_iterinit(PL_pidstatus); if ((entry = hv_iternext(PL_pidstatus))) { + SV *sv = hv_iterval(PL_pidstatus,entry); + pid = atoi(hv_iterkey(entry,(I32*)statusp)); - sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); sprintf(spid, "%"IVdf, (IV)pid); (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); @@ -2606,7 +2617,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) goto finish; #endif #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) +#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) hard_way: +#endif { if (flags) Perl_croak(aTHX_ "Can't do waitpid with flags"); @@ -2618,7 +2631,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) } } #endif +#if defined(HAS_WAITPID) || defined(HAS_WAIT4) finish: +#endif if (result < 0 && errno == EINTR) { PERL_ASYNC_CHECK(); } @@ -2967,6 +2982,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc void * Perl_get_context(void) { + dVAR; #if defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; @@ -2988,6 +3004,7 @@ Perl_get_context(void) void Perl_set_context(void *t) { + dVAR; #if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); @@ -3000,7 +3017,7 @@ Perl_set_context(void *t) #endif /* !PERL_GET_CONTEXT_DEFINED */ -#ifdef PERL_GLOBAL_STRUCT +#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) struct perl_vars * Perl_GetVars(pTHX) { @@ -3011,13 +3028,13 @@ Perl_GetVars(pTHX) char ** Perl_get_op_names(pTHX) { - return PL_op_name; + return (char **)PL_op_name; } char ** Perl_get_op_descs(pTHX) { - return PL_op_desc; + return (char **)PL_op_desc; } const char * @@ -3029,12 +3046,13 @@ Perl_get_no_modify(pTHX) U32 * Perl_get_opargs(pTHX) { - return PL_opargs; + return (U32 *)PL_opargs; } PPADDR_t* Perl_get_ppaddr(pTHX) { + dVAR; return (PPADDR_t*)PL_ppaddr; } @@ -3053,7 +3071,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) { - MGVTBL* result = Null(MGVTBL*); + const MGVTBL* result = Null(MGVTBL*); switch(vtbl_id) { case want_vtbl_sv: @@ -3149,7 +3167,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) result = &PL_vtbl_utf8; break; } - return result; + return (MGVTBL*)result; } I32 @@ -3613,6 +3631,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in } #else Perl_croak(aTHX_ "panic: no strftime"); + return NULL; #endif } @@ -4425,7 +4444,15 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { return 0; abort_tidy_up_and_fail: - errno = ECONNABORTED; /* I hope this is portable and appropriate. */ +#ifdef ECONNABORTED + errno = ECONNABORTED; /* This would be the standard thing to do. */ +#else +# ifdef ECONNREFUSED + errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */ +# else + errno = ETIMEDOUT; /* Desperation time. */ +# endif +#endif tidy_up_and_fail: { int save_errno = errno; @@ -4609,7 +4636,7 @@ Perl_seed(pTHX) #endif fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); if (fd != -1) { - if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) + if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) u = 0; PerlLIO_close(fd); if (u) @@ -4673,3 +4700,73 @@ Perl_get_hash_seed(pTHX) return myseed; } + +#ifdef PERL_GLOBAL_STRUCT + +struct perl_vars * +Perl_init_global_struct(pTHX) +{ + struct perl_vars *plvarsp = NULL; +#ifdef PERL_GLOBAL_STRUCT +# define PERL_GLOBAL_STRUCT_INIT +# include "opcode.h" /* the ppaddr and check */ + IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t); + IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ + plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); + if (!plvarsp) + exit(1); +# else + plvarsp = PL_VarsPtr; +# endif /* PERL_GLOBAL_STRUCT_PRIVATE */ +# define PERLVAR(var,type) /**/ +# define PERLVARA(var,n,type) /**/ +# define PERLVARI(var,type,init) plvarsp->var = init; +# define PERLVARIC(var,type,init) plvarsp->var = init; +# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char); +# include "perlvars.h" +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC +# undef PERLVARISC +# ifdef PERL_GLOBAL_STRUCT + plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); + if (!plvarsp->Gppaddr) + exit(1); + plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t)); + if (!plvarsp->Gcheck) + exit(1); + Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); + Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t); +# endif +# ifdef PERL_SET_VARS + PERL_SET_VARS(plvarsp); +# endif +# undef PERL_GLOBAL_STRUCT_INIT +#endif + return plvarsp; +} + +#endif /* PERL_GLOBAL_STRUCT */ + +#ifdef PERL_GLOBAL_STRUCT + +void +Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) +{ +#ifdef PERL_GLOBAL_STRUCT +# ifdef PERL_UNSET_VARS + PERL_UNSET_VARS(plvarsp); +# endif + free(plvarsp->Gppaddr); + free(plvarsp->Gcheck); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + free(plvarsp); +# endif +#endif +} + +#endif /* PERL_GLOBAL_STRUCT */ + diff --git a/util.h b/util.h index 1a1c9ff..7d37352 100644 --- a/util.h +++ b/util.h @@ -27,11 +27,11 @@ || ((f)[0] == '\\' && (f)[1] == '\\') /* UNC path */ \ || ((f)[3] == ':')) /* volume name, currently only sys */ # else /* !NETWARE */ -# if defined( DOSISH) || defined(EPOC) +# if defined( DOSISH) || defined(EPOC) || defined(SYMBIAN) # define PERL_FILE_IS_ABSOLUTE(f) \ (*(f) == '/' \ || ((f)[0] && (f)[1] == ':')) /* drive name */ -# else /* NEITHER DOSISH NOR EPOCISH */ +# else /* NEITHER DOSISH NOR EPOCISH NOR SYMBIANISH */ # ifdef MACOS_TRADITIONAL # define PERL_FILE_IS_ABSOLUTE(f) (strchr(f, ':') && *(f) != ':') # else /* !MACOS_TRADITIONAL */ diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index 519332f..cfd929a 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -394,11 +394,12 @@ pod16 = [.lib.pod]perlnetware.pod [.lib.pod]perlnewmod.pod [.lib.pod]perlnumber. pod17 = [.lib.pod]perlos2.pod [.lib.pod]perlos390.pod [.lib.pod]perlos400.pod [.lib.pod]perlothrtut.pod [.lib.pod]perlpacktut.pod [.lib.pod]perlplan9.pod pod18 = [.lib.pod]perlpod.pod [.lib.pod]perlpodspec.pod [.lib.pod]perlport.pod [.lib.pod]perlqnx.pod [.lib.pod]perlre.pod [.lib.pod]perlref.pod pod19 = [.lib.pod]perlreftut.pod [.lib.pod]perlrequick.pod [.lib.pod]perlreref.pod [.lib.pod]perlretut.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod -pod20 = [.lib.pod]perlsolaris.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perlthrtut.pod [.lib.pod]perltie.pod -pod21 = [.lib.pod]perltoc.pod [.lib.pod]perltodo.pod [.lib.pod]perltooc.pod [.lib.pod]perltoot.pod [.lib.pod]perltrap.pod [.lib.pod]perltru64.pod -pod22 = [.lib.pod]perltw.pod [.lib.pod]perlunicode.pod [.lib.pod]perluniintro.pod [.lib.pod]perlutil.pod [.lib.pod]perluts.pod [.lib.pod]perlvar.pod -pod23 = [.lib.pod]perlvmesa.pod [.lib.pod]perlvms.pod [.lib.pod]perlvos.pod [.lib.pod]perlwin32.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod -pod = $(pod0) $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) $(pod11) $(pod12) $(pod13) $(pod14) $(pod15) $(pod16) $(pod17) $(pod18) $(pod19) $(pod20) $(pod21) $(pod22) $(pod23) +pod20 = [.lib.pod]perlsolaris.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsymbian.pod [.lib.pod]perlsyn.pod [.lib.pod]perlthrtut.pod +pod21 = [.lib.pod]perltie.pod [.lib.pod]perltoc.pod [.lib.pod]perltodo.pod [.lib.pod]perltooc.pod [.lib.pod]perltoot.pod [.lib.pod]perltrap.pod +pod22 = [.lib.pod]perltru64.pod [.lib.pod]perltw.pod [.lib.pod]perlunicode.pod [.lib.pod]perluniintro.pod [.lib.pod]perlutil.pod [.lib.pod]perluts.pod +pod23 = [.lib.pod]perlvar.pod [.lib.pod]perlvmesa.pod [.lib.pod]perlvms.pod [.lib.pod]perlvos.pod [.lib.pod]perlwin32.pod [.lib.pod]perlxs.pod +pod24 = [.lib.pod]perlxstut.pod +pod = $(pod0) $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) $(pod9) $(pod10) $(pod11) $(pod12) $(pod13) $(pod14) $(pod15) $(pod16) $(pod17) $(pod18) $(pod19) $(pod20) $(pod21) $(pod22) $(pod23) $(pod24) # Would be useful to automate the generation of this rule from pod/buildtoc # Plus its corresponding delete in the clean target. @@ -1147,6 +1148,10 @@ preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod] +[.lib.pod]perlsymbian.pod : [.pod]perlsymbian.pod + @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] + Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod] + [.lib.pod]perlsyn.pod : [.pod]perlsyn.pod @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod] diff --git a/win32/Makefile b/win32/Makefile index 6138ee7..fdac9c1 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -1077,6 +1077,7 @@ utils: $(PERLEXE) $(X2P) copy ..\README.plan9 ..\pod\perlplan9.pod copy ..\README.qnx ..\pod\perlqnx.pod copy ..\README.solaris ..\pod\perlsolaris.pod + copy ..\README.symbian ..\pod\perlsymbian.pod copy ..\README.tru64 ..\pod\perltru64.pod copy ..\README.tw ..\pod\perltw.pod copy ..\README.uts ..\pod\perluts.pod @@ -1159,9 +1160,9 @@ distclean: realclean perljp.pod perlko.pod perlmachten.pod perlmacos.pod \ perlmacosx.pod perlmint.pod perlmpeix.pod perlnetware.pod \ perlos2.pod perlos390.pod perlos400.pod perlplan9.pod \ - perlqnx.pod perlsolaris.pod perltru64.pod perltw.pod \ - perluts.pod perlvmesa.pod perlvms.pod perlvms.pod perlvos.pod \ - perlwin32.pod \ + perlqnx.pod perlsolaris.pod perlsymbian.pod perltru64.pod \ + perltw.pod perluts.pod perlvmesa.pod perlvms.pod perlvms.pod \ + perlvos.pod perlwin32.pod \ pod2html pod2latex pod2man pod2text pod2usage \ podchecker podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ diff --git a/win32/makefile.mk b/win32/makefile.mk index 3e54941..92cd12b 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -1239,6 +1239,7 @@ utils: $(PERLEXE) $(X2P) copy ..\README.plan9 ..\pod\perlplan9.pod copy ..\README.qnx ..\pod\perlqnx.pod copy ..\README.solaris ..\pod\perlsolaris.pod + copy ..\README.symbian ..\pod\perlsymbian.pod copy ..\README.tru64 ..\pod\perltru64.pod copy ..\README.tw ..\pod\perltw.pod copy ..\README.uts ..\pod\perluts.pod @@ -1318,9 +1319,9 @@ distclean: realclean perljp.pod perlko.pod perlmachten.pod perlmacos.pod \ perlmacosx.pod perlmint.pod perlmpeix.pod perlnetware.pod \ perlos2.pod perlos390.pod perlos400.pod perlplan9.pod \ - perlqnx.pod perlsolaris.pod perltru64.pod perltw.pod \ - perluts.pod perlvmesa.pod perlvms.pod perlvms.pod perlvos.pod \ - perlwin32.pod \ + perlqnx.pod perlsolaris.pod perlsymbian.pod perltru64.pod \ + perltw.pod perluts.pod perlvmesa.pod perlvms.pod perlvms.pod \ + perlvos.pod perlwin32.pod \ pod2html pod2latex pod2man pod2text pod2usage \ podchecker podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ diff --git a/win32/win32io.c b/win32/win32io.c index f0f71e7..80185fe 100644 --- a/win32/win32io.c +++ b/win32/win32io.c @@ -340,7 +340,7 @@ PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags) return f; } -PerlIO_funcs PerlIO_win32 = { +PERLIO_FUNCS_DECL(PerlIO_win32) = { sizeof(PerlIO_funcs), "win32", sizeof(PerlIOWin32), diff --git a/xsutils.c b/xsutils.c index a8a95e2..4f7324f 100644 --- a/xsutils.c +++ b/xsutils.c @@ -23,12 +23,12 @@ */ /* package attributes; */ -void XS_attributes__warn_reserved(pTHX_ CV *cv); -void XS_attributes_reftype(pTHX_ CV *cv); -void XS_attributes__modify_attrs(pTHX_ CV *cv); -void XS_attributes__guess_stash(pTHX_ CV *cv); -void XS_attributes__fetch_attrs(pTHX_ CV *cv); -void XS_attributes_bootstrap(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_attributes__warn_reserved(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv); /*