+++ /dev/null
-/* dl_os2.xs
- *
- * Platform: OS/2.
- * Author: Andreas Kaiser (ak@ananke.s.bawue.de)
- * Created: 08th December 1994
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-#define INCL_BASE
-#include <os2.h>
-
-#include "dlutils.c" /* SaveError() etc */
-
-static ULONG retcode;
-
-static void *
-dlopen(char *path, int mode)
-{
- HMODULE handle;
- char tmp[260], *beg, *dot;
- char fail[300];
- ULONG rc;
-
- if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
- return (void *)handle;
-
- retcode = rc;
-
- /* Not found. Check for non-FAT name and try truncated name. */
- /* Don't know if this helps though... */
- for (beg = dot = path + strlen(path);
- beg > path && !strchr(":/\\", *(beg-1));
- beg--)
- if (*beg == '.')
- dot = beg;
- if (dot - beg > 8) {
- int n = beg+8-path;
- memmove(tmp, path, n);
- memmove(tmp+n, dot, strlen(dot)+1);
- if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
- return (void *)handle;
- }
-
- return NULL;
-}
-
-static void *
-dlsym(void *handle, char *symbol)
-{
- ULONG rc, type;
- PFN addr;
-
- rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
- if (rc == 0) {
- rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
- if (rc == 0 && type == PT_32BIT)
- return (void *)addr;
- rc = ERROR_CALL_NOT_IMPLEMENTED;
- }
- retcode = rc;
- return NULL;
-}
-
-static char *
-dlerror(void)
-{
- static char buf[300];
- ULONG len;
-
- if (retcode == 0)
- return NULL;
- if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
- sprintf(buf, "OS/2 system error code %d", retcode);
- else
- buf[len] = '\0';
- retcode = 0;
- return buf;
-}
-
-
-static void
-dl_private_init()
-{
- (void)dl_generic_private_init();
-}
-
-static char *
-mod2fname(sv)
- SV *sv;
-{
- static char fname[9];
- int pos = 7;
- int len;
- AV *av;
- SV *svp;
- char *s;
-
- if (!SvROK(sv)) croak("Not a reference given to mod2fname");
- sv = SvRV(sv);
- if (SvTYPE(sv) != SVt_PVAV)
- croak("Not array reference given to mod2fname");
- if (av_len((AV*)sv) < 0)
- croak("Empty array reference given to mod2fname");
- s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
- strncpy(fname, s, 8);
- if ((len=strlen(s)) < 7) pos = len;
- fname[pos] = '_';
- fname[pos + 1] = '\0';
- return (char *)fname;
-}
-
-MODULE = DynaLoader PACKAGE = DynaLoader
-
-BOOT:
- (void)dl_private_init();
-
-
-void *
-dl_load_file(filename)
- char * filename
- CODE:
- int mode = 1; /* Solaris 1 */
-#ifdef RTLD_LAZY
- mode = RTLD_LAZY; /* Solaris 2 */
-#endif
- DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename));
- RETVAL = dlopen(filename, mode) ;
- DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
- ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
- SaveError("%s",dlerror()) ;
- else
- sv_setiv( ST(0), (IV)RETVAL);
-
-
-void *
-dl_find_symbol(libhandle, symbolname)
- void * libhandle
- char * symbolname
- CODE:
-#ifdef DLSYM_NEEDS_UNDERSCORE
- char symbolname_buf[1024];
- symbolname = dl_add_underscore(symbolname, symbolname_buf);
-#endif
- DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n",
- libhandle, symbolname));
- RETVAL = dlsym(libhandle, symbolname);
- DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL));
- ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
- SaveError("%s",dlerror()) ;
- else
- sv_setiv( ST(0), (IV)RETVAL);
-
-
-void
-dl_undef_symbols()
- PPCODE:
-
-char *
-mod2fname(sv)
- SV *sv;
-
-
-# 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:
- DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
- perl_name, symref));
- ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
-
-
-char *
-dl_error()
- CODE:
- RETVAL = LastError ;
- OUTPUT:
- RETVAL
-
-# end.
--- /dev/null
+Check existing $^W functionality
+
+__END__
+
+# warnable code, warnings disabled
+$a =+ 3 ;
+EXPECT
+
+########
+-w
+# warnable code, warnings enabled via command line switch
+$a =+ 3 ;
+EXPECT
+Reversed += operator at - line 3.
+########
+#! perl -w
+# warnable code, warnings enabled via #! line
+$a =+ 3 ;
+EXPECT
+Reversed += operator at - line 3.
+########
+
+# warnable code, warnings enabled via compile time $^W
+BEGIN { $^W = 1 }
+$a =+ 3 ;
+EXPECT
+Reversed += operator at - line 4.
+########
+
+# compile-time warnable code, warnings enabled via runtime $^W
+# so no warning printed.
+$^W = 1 ;
+$a =+ 3 ;
+EXPECT
+
+########
+
+# warnable code, warnings enabled via runtime $^W
+$^W = 1 ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 4.
+########
+
+# warnings enabled at compile time, disabled at run time
+BEGIN { $^W = 1 }
+$^W = 0 ;
+my $b ; chop $b ;
+EXPECT
+
+########
+
+# warnings disabled at compile time, enabled at run time
+BEGIN { $^W = 0 }
+$^W = 1 ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 5.
+########
+-w
+--FILE-- abcd
+my $b ; chop $b ;
+1 ;
+--FILE--
+require "./abcd";
+EXPECT
+Use of uninitialized value at ./abcd line 1.
+########
+
+--FILE-- abcd
+my $b ; chop $b ;
+1 ;
+--FILE--
+#! perl -w
+require "./abcd";
+EXPECT
+Use of uninitialized value at ./abcd line 1.
+########
+
+--FILE-- abcd
+my $b ; chop $b ;
+1 ;
+--FILE--
+$^W =1 ;
+require "./abcd";
+EXPECT
+Use of uninitialized value at ./abcd line 1.
+########
+
+--FILE-- abcd
+$^W = 0;
+my $b ; chop $b ;
+1 ;
+--FILE--
+$^W =1 ;
+require "./abcd";
+EXPECT
+
+########
+
+--FILE-- abcd
+$^W = 1;
+1 ;
+--FILE--
+$^W =0 ;
+require "./abcd";
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 3.
+########
+
+$^W = 1;
+eval "my $b ; chop $b ;" ;
+EXPECT
+Use of uninitialized value at - line 3.
+Use of uninitialized value at - line 3.
+########
+
+eval "$^W = 1;" ;
+my $b ; chop $b ;
+EXPECT
+
+########
+
+eval {$^W = 1;} ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 3.
+########
+
+{
+ local ($^W) = 1;
+}
+my $b ; chop $b ;
+EXPECT
+
+########
+
+my $a ; chop $a ;
+{
+ local ($^W) = 1;
+ my $b ; chop $b ;
+}
+my $c ; chop $c ;
+EXPECT
+Use of uninitialized value at - line 5.
+++ /dev/null
-Check existing $^W functionality
-
-__END__
-
-# warnable code, warnings disabled
-$a =+ 3 ;
-EXPECT
-
-########
--w
-# warnable code, warnings enabled via command line switch
-$a =+ 3 ;
-EXPECT
-Reversed += operator at - line 3.
-########
-#! perl -w
-# warnable code, warnings enabled via #! line
-$a =+ 3 ;
-EXPECT
-Reversed += operator at - line 3.
-########
-
-# warnable code, warnings enabled via compile time $^W
-BEGIN { $^W = 1 }
-$a =+ 3 ;
-EXPECT
-Reversed += operator at - line 4.
-########
-
-# compile-time warnable code, warnings enabled via runtime $^W
-# so no warning printed.
-$^W = 1 ;
-$a =+ 3 ;
-EXPECT
-
-########
-
-# warnable code, warnings enabled via runtime $^W
-$^W = 1 ;
-my $b ; chop $b ;
-EXPECT
-Use of uninitialized value at - line 4.
-########
-
-# warnings enabled at compile time, disabled at run time
-BEGIN { $^W = 1 }
-$^W = 0 ;
-my $b ; chop $b ;
-EXPECT
-
-########
-
-# warnings disabled at compile time, enabled at run time
-BEGIN { $^W = 0 }
-$^W = 1 ;
-my $b ; chop $b ;
-EXPECT
-Use of uninitialized value at - line 5.
-########
--w
---FILE-- abcd
-my $b ; chop $b ;
-1 ;
---FILE--
-require "./abcd";
-EXPECT
-Use of uninitialized value at ./abcd line 1.
-########
-
---FILE-- abcd
-my $b ; chop $b ;
-1 ;
---FILE--
-#! perl -w
-require "./abcd";
-EXPECT
-Use of uninitialized value at ./abcd line 1.
-########
-
---FILE-- abcd
-my $b ; chop $b ;
-1 ;
---FILE--
-$^W =1 ;
-require "./abcd";
-EXPECT
-Use of uninitialized value at ./abcd line 1.
-########
-
---FILE-- abcd
-$^W = 0;
-my $b ; chop $b ;
-1 ;
---FILE--
-$^W =1 ;
-require "./abcd";
-EXPECT
-
-########
-
---FILE-- abcd
-$^W = 1;
-1 ;
---FILE--
-$^W =0 ;
-require "./abcd";
-my $b ; chop $b ;
-EXPECT
-Use of uninitialized value at - line 3.
-########
-
-$^W = 1;
-eval "my $b ; chop $b ;" ;
-EXPECT
-Use of uninitialized value at - line 3.
-Use of uninitialized value at - line 3.
-########
-
-eval "$^W = 1;" ;
-my $b ; chop $b ;
-EXPECT
-
-########
-
-eval {$^W = 1;} ;
-my $b ; chop $b ;
-EXPECT
-Use of uninitialized value at - line 3.
-########
-
-{
- local ($^W) = 1;
-}
-my $b ; chop $b ;
-EXPECT
-
-########
-
-my $a ; chop $a ;
-{
- local ($^W) = 1;
- my $b ; chop $b ;
-}
-my $c ; chop $c ;
-EXPECT
-Use of uninitialized value at - line 5.