Gisle Aas <gisle@aas.no>
Kenneth Albanowski <kjahds@kjahds.com>
- Charles Bailey <bailey@hmivax.humgen.upenn.edu>
Graham Barr <gbarr@ti.com>
Spider Boardman <spider@orb.nashua.nh.us>
Tim Bunce <Tim.Bunce@ig.co.uk>
And the Keepers of the Patch Pumpkin:
+ Charles Bailey <bailey@hmivax.humgen.upenn.edu>
Andy Dougherty <doughera@lafcol.lafayette.edu>
- Chip Salzenberg <chip@pobox.com>
+ Chip Salzenberg <chip@perl.com>
+
+
+-------------------
+ Version 5.003_97f
+-------------------
+
+This is it before _98. No more last-minute features. Really, I mean
+it this time. No kidding.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "New operator systell()"
+ From: Chip Salzenberg
+ Files: doio.c ext/Opcode/Opcode.pm keywords.pl opcode.pl
+ pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod pp_sys.c
+ t/op/sysio.t toke.c
+
+ Title: "Allow constant sub to be optimized when called with parens"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Make {,un}pack fail on invalid pack types"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod pp.c
+
+ CORE PORTABILITY
+
+ Title: "Fix bitwise ops and {,un}pack() on Cray CPUs"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "VMS update"
+ From: Charles Bailey
+ Files: lib/Cwd.pm lib/File/Path.pm lib/FindBin.pm vms/perly_c.vms
+ vms/vms.c vms/writemain.pl
+
+ Title: "Win32 update (three patches)"
+ From: Gurusamy Sarathy and Nick Ing-Simmons
+ Files: lib/Cwd.pm lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_Win32.pm
+ lib/File/Basename.pm win32/Makefile win32/makedef.pl
+ win32/perllib.c win32/win32.c win32/win32iop.h
+
+ OTHER CORE CHANGES
+
+ Title: "Fix error messages on method lookup failure"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix use of var before init in util.c"
+ From: Gurusamy Sarathy
+ Msg-ID: <199704162342.TAA20773@aatma.engin.umich.edu>
+ Date: Wed, 16 Apr 1997 19:42:41 -0400
+ Files: util.c
+
+ BUILD PROCESS
+
+ Title: "Linux hints: Allow build w/o suidperl, prefer tcsh to csh"
+ From: Michael De La Rue <mikedlr@tardis.ed.ac.uk>
+ Files: Configure hints/linux.sh
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Fix bug in Opcode when (maxo & 15) > 8"
+ From: Chip Salzenberg
+ Files: ext/Opcode/Makefile.PL ext/Opcode/Opcode.pm
+ ext/Opcode/Opcode.xs
+
+ Title: "CGI.pm broke again"
+ From: Andreas Koenig
+ Msg-ID: <199704171136.NAA24859@anna.in-berlin.de>
+ Date: Thu, 17 Apr 1997 13:36:28 +0200
+ Files: lib/CGI.pm
+
+ Title: "Revise quotewords()"
+ From: Shishir Gundavaram <shishir@ruby.ora.com>
+ Files: lib/Text/ParseWords.pm
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ (no changes)
+
+ DOCUMENTATION
+
+ Title: "Doc updates: INSTALL-1.13, pumpkin.pod-1.9"
+ From: Andy Dougherty
+ Files: INSTALL Porting/pumpkin.pod
+
+ Title: "Document size restrictions for packed integers"
+ From: Jarkko Hietaniemi
+ Files: pod/perlfunc.pod
-------------------
GV *gv;
{
register IO *io;
+ register PerlIO *fp;
- if (!gv)
- goto phooey;
-
- io = GvIO(gv);
- if (!io || !IoIFP(io))
- goto phooey;
-
+ if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
#ifdef ULTRIX_STDIO_BOTCH
- if (PerlIO_eof(IoIFP(io)))
- (void)PerlIO_seek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
+ if (PerlIO_eof(fp))
+ (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
#endif
-
- return PerlIO_tell(IoIFP(io));
-
-phooey:
+ if (op->op_type == OP_SYSTELL)
+ return lseek(PerlIO_fileno(fp), 0L, 1);
+ else
+ return PerlIO_tell(fp);
+ }
if (dowarn)
- warn("tell() on unopened file");
+ warn("%s() on unopened file", op_name[op->op_type]);
SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
return PerlIO_seek(fp, pos, whence) >= 0;
}
if (dowarn)
- warn("seek() on unopened file");
+ warn("%s() on unopened file", op_name[op->op_type]);
SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
NAME => 'Opcode',
MAN3PODS => ' ',
VERSION_FROM => 'Opcode.pm',
- XS_VERSION => '1.00'
+ XS_VERSION => '1.01'
);
use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK);
-$VERSION = "1.02";
-$XS_VERSION = "1.00";
+$VERSION = "1.03";
+$XS_VERSION = "1.01";
use strict;
use Carp;
formline enterwrite leavewrite
- print sysread syswrite send recv eof tell seek sysseek
+ print sysread syswrite send recv
+
+ eof tell seek systell sysseek
readdir telldir seekdir rewinddir
while(i-- > 0)
bitmap[i] = 0xFF;
/* Take care to set the right number of bits in the last byte */
- bitmap[len-1] = (maxo & 0x07) ? ~(~0 << (maxo & 0x07)) : 0xFF;
+ bitmap[len-1] = ~(0xFF << (maxo & 0x07));
put_op_bitspec(":all",0, opset_all); /* don't mortalise */
}
while(len-- > 0)
bitmap[len] = ~bitmap[len];
/* take care of extra bits beyond maxo in last byte */
- bitmap[opset_len-1] &= ~(0xFF << (maxo & 0x0F));
+ bitmap[opset_len-1] &= ~(0xFF << (maxo & 0x07));
}
ST(0) = opset;
#define KEY_sysopen 211
#define KEY_sysread 212
#define KEY_sysseek 213
-#define KEY_system 214
-#define KEY_syswrite 215
-#define KEY_tell 216
-#define KEY_telldir 217
-#define KEY_tie 218
-#define KEY_tied 219
-#define KEY_time 220
-#define KEY_times 221
-#define KEY_tr 222
-#define KEY_truncate 223
-#define KEY_uc 224
-#define KEY_ucfirst 225
-#define KEY_umask 226
-#define KEY_undef 227
-#define KEY_unless 228
-#define KEY_unlink 229
-#define KEY_unpack 230
-#define KEY_unshift 231
-#define KEY_untie 232
-#define KEY_until 233
-#define KEY_use 234
-#define KEY_utime 235
-#define KEY_values 236
-#define KEY_vec 237
-#define KEY_wait 238
-#define KEY_waitpid 239
-#define KEY_wantarray 240
-#define KEY_warn 241
-#define KEY_while 242
-#define KEY_write 243
-#define KEY_x 244
-#define KEY_xor 245
-#define KEY_y 246
+#define KEY_systell 214
+#define KEY_system 215
+#define KEY_syswrite 216
+#define KEY_tell 217
+#define KEY_telldir 218
+#define KEY_tie 219
+#define KEY_tied 220
+#define KEY_time 221
+#define KEY_times 222
+#define KEY_tr 223
+#define KEY_truncate 224
+#define KEY_uc 225
+#define KEY_ucfirst 226
+#define KEY_umask 227
+#define KEY_undef 228
+#define KEY_unless 229
+#define KEY_unlink 230
+#define KEY_unpack 231
+#define KEY_unshift 232
+#define KEY_untie 233
+#define KEY_until 234
+#define KEY_use 235
+#define KEY_utime 236
+#define KEY_values 237
+#define KEY_vec 238
+#define KEY_wait 239
+#define KEY_waitpid 240
+#define KEY_wantarray 241
+#define KEY_warn 242
+#define KEY_while 243
+#define KEY_write 244
+#define KEY_x 245
+#define KEY_xor 246
+#define KEY_y 247
sysopen
sysread
sysseek
+systell
system
syswrite
tell
package Cwd;
require 5.000;
-require Exporter;
-use Carp;
=head1 NAME
=cut
+## use strict;
+
+use Carp;
+
+$VERSION = '2.00';
+
+require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
-@EXPORT_OK = qw(chdir abs_path fast_abspath);
+@EXPORT_OK = qw(chdir abs_path fast_abs_path);
-# use strict;
# The 'natural and safe form' for UNIX (pwd may be setuid root)
+
sub _backtick_pwd {
my $cwd;
chop($cwd = `pwd`);
$cwd;
}
-sub fast_abspath
-{
- my $cwd = getcwd();
- my $path = shift || '.';
- chdir($path) || croak "Cannot chdir to $path:$!";
- my $realpath = getcwd();
- chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
- $realpath;
+sub fast_abs_path {
+ my $cwd = getcwd();
+ my $path = shift || '.';
+ chdir($path) || croak "Cannot chdir to $path:$!";
+ my $realpath = getcwd();
+ chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
+ $realpath;
}
# the CRTL chdir() function persist only until Perl exits.
sub _vms_cwd {
- return $ENV{'DEFAULT'}
+ return $ENV{'DEFAULT'};
+}
+
+sub _vms_abs_path {
+ return $ENV{'DEFAULT'} unless @_;
+ my $path = VMS::Filespec::pathify($_[0]);
+ croak("Invalid path name $_[0]") unless defined $path;
+ return VMS::Filespec::rmsexpand($path);
}
sub _os2_cwd {
return $ENV{'PWD'};
}
-*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
+sub _win32_cwd {
+ $ENV{'PWD'} = Win32::GetCurrentDirectory();
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
+ defined &Win32::GetCurrentDirectory);
+
+*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
sub _msdos_cwd {
$ENV{'PWD'} = `command /c cd`;
local $^W = 0; # assignments trigger 'subroutine redefined' warning
if ($^O eq 'VMS') {
- *cwd = \&_vms_cwd;
- *getcwd = \&_vms_cwd;
- *fastcwd = \&_vms_cwd;
- *fastgetcwd = \&_vms_cwd;
- *abs_path = \&fast_abspath;
+ *cwd = \&_vms_cwd;
+ *getcwd = \&_vms_cwd;
+ *fastcwd = \&_vms_cwd;
+ *fastgetcwd = \&_vms_cwd;
+ *abs_path = \&_vms_abs_path;
+ *fast_abs_path = \&_vms_abs_path;
}
elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
# We assume that &_NT_cwd is defined as an XSUB or in the core.
- *cwd = \&_NT_cwd;
- *getcwd = \&_NT_cwd;
- *fastcwd = \&_NT_cwd;
- *fastgetcwd = \&_NT_cwd;
- *abs_path = \&fast_abspath;
+ *cwd = \&_NT_cwd;
+ *getcwd = \&_NT_cwd;
+ *fastcwd = \&_NT_cwd;
+ *fastgetcwd = \&_NT_cwd;
+ *abs_path = \&fast_abs_path;
}
elsif ($^O eq 'os2') {
# sys_cwd may keep the builtin command
- *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *abs_path = \&fast_abspath;
+ *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *getcwd = \&cwd;
+ *fastgetcwd = \&cwd;
+ *fastcwd = \&cwd;
+ *abs_path = \&fast_abs_path;
}
elsif ($^O eq 'msdos') {
- *cwd = \&_msdos_cwd;
- *getcwd = \&_msdos_cwd;
- *fastgetcwd = \&_msdos_cwd;
- *fastcwd = \&_msdos_cwd;
- *abs_path = \&fast_abspath;
+ *cwd = \&_msdos_cwd;
+ *getcwd = \&_msdos_cwd;
+ *fastgetcwd = \&_msdos_cwd;
+ *fastcwd = \&_msdos_cwd;
+ *abs_path = \&fast_abs_path;
}
}
# --- Test and Installation Sections ---
my($self, %attribs) = @_;
- my($tests) = $attribs{TESTS} || (-d "t" ? "t/*.t" : "");
+ my $tests = $attribs{TESTS};
+ if (!$tests && -d 't') {
+ $tests = $Is_Win32 ? join(' ', <t\\*.t>) : 't/*.t';
+ }
my(@m);
push(@m,"
TEST_VERBOSE=0
my $file = pop @_;
return $file unless @_;
my $dir = $self->catdir(@_);
- for ($dir) {
- $_ .= "\\" unless substr($_,length($_)-1,1) eq "\\";
- }
+ $dir =~ s/(\\\.)$//;
+ $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\";
return $dir.$file;
}
sub canonpath {
my($self,$path) = @_;
+ $path =~ s/^([a-z]:)/\u$1/;
$path =~ s|/|\\|g;
$path =~ s|\\+|\\|g ; # xx////xx -> xx/xx
$path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx
($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/);
}
}
- if ($fstype =~ /^MSDOS/i) {
+ if ($fstype =~ /^MS(DOS|Win32)/i) {
($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/);
$dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/;
}
($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/);
$dirpath = './' unless $dirpath;
}
- elsif ($fstype =~ /^MSWin32/i) {
- ($dirpath,$basename) = ($fullname =~ /^(.*[:\\\/])?(.*)/);
- $dirpath .= ".\\" unless $dirpath =~ /[\\\/]$/;
- }
elsif ($fstype !~ /^VMS/i) { # default to Unix
($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#);
$dirpath = './' unless $dirpath;
(if running under VMS) or write access (if running
under another OS). This will change in the future when
a criterion for 'delete permission' under OSs other
-than VMS is settled. (defaults to FALSE)
+than VMS is settled. (defaults to FALSE)
=back
-It returns the number of files successfully deleted. Symlinks are
+It returns the number of files successfully deleted. Symlinks are
treated as ordinary files.
+B<NOTE:> If the third parameter is not TRUE, C<rmtree> is B<unsecure>
+in the face of failure or interruption. Files and directories which
+were not deleted may be left with permissions reset to allow world
+read and write access. Note also that the occurrence of errors in
+rmtree can be determined I<only> by trapping diagnostic messages
+using C<$SIG{__WARN__}>; it is not apparent from the return value.
+Therefore, you must be extremely careful about using C<rmtree($foo,$bar,0>
+in situations where security is an issue.
+
=head1 AUTHORS
-Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>
-Charles Bailey E<lt>F<bailey@genetics.upenn.edu>E<gt>
+Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
+Charles Bailey <F<bailey@genetics.upenn.edu>>
=head1 REVISION
-Current $VERSION is 1.02.
+Current $VERSION is 1.03.
=cut
use strict;
use vars qw( $VERSION @ISA @EXPORT );
-$VERSION = "1.02";
+$VERSION = "1.03";
@ISA = qw( Exporter );
@EXPORT = qw( mkpath rmtree );
my($root);
foreach $root (@{$roots}) {
$root =~ s#/$##;
- $count++, next unless -e $root;
+ next unless -e $root;
if (not -l $root and -d _) {
# notabene: 0777 is for making readable in the first place,
# it's also intended to change it to writable in case we have
# to recurse in which case we are better than rm -rf for
# subtrees with strange permissions
- chmod 0777, $root
+ my $rp = (stat(_))[2] & 0777; #Is this portable???
+ chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
or carp "Can't make directory $root read+writeable: $!"
unless $safe;
or carp "Can't make directory $root writeable: $!"
if $force_writeable;
print "rmdir $root\n" if $verbose;
- rmdir($root) && ++$count
- or carp "Can't remove directory $root: $!";
+ if (rmdir $root) {
+ ++$count;
+ }
+ else {
+ carp "Can't remove directory $root: $!";
+ chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ or carp("and can't restore permissions to "
+ . sprintf("0%o",$rp) . "\n");
+ }
}
else {
if ($safe &&
print "skipped $root\n" if $verbose;
next;
}
+ my $rp = (stat(_))[2] & 0777; #Is this portable???
chmod 0666, $root
or carp "Can't make file $root writeable: $!"
if $force_writeable;
print "unlink $root\n" if $verbose;
# delete all versions under VMS
while (-e $root || -l $root) {
- unlink($root) && ++$count
- or croak "Can't unlink file $root: $!";
+ if (unlink $root) {
+ ++$count;
+ }
+ else {
+ carp "Can't unlink file $root: $!";
+ if ($force_writeable) {
+ chmod $rp, $root
+ or carp("and can't restore permissions to "
+ . sprintf("0%o",$rp) . "\n");
+ }
+ }
}
}
}
{
return m#^[a-z]:[\\/]#i;
}
+ elsif ($^O eq 'VMS')
+ {
+ # If it's a logical name, expand it.
+ $_ = $ENV{$_} while /^[\w\$\-]+$/ and $ENV{$_};
+ return m!^/! or m![<\[][^.\-\]>]! or /:[^<\[]/;
+ }
else
{
return m#^/#;
OP_PRTF, /* 205 */
OP_PRINT, /* 206 */
OP_SYSOPEN, /* 207 */
- OP_SYSSEEK, /* 208 */
- OP_SYSREAD, /* 209 */
- OP_SYSWRITE, /* 210 */
- OP_SEND, /* 211 */
- OP_RECV, /* 212 */
- OP_EOF, /* 213 */
- OP_TELL, /* 214 */
- OP_SEEK, /* 215 */
- OP_TRUNCATE, /* 216 */
- OP_FCNTL, /* 217 */
- OP_IOCTL, /* 218 */
- OP_FLOCK, /* 219 */
- OP_SOCKET, /* 220 */
- OP_SOCKPAIR, /* 221 */
- OP_BIND, /* 222 */
- OP_CONNECT, /* 223 */
- OP_LISTEN, /* 224 */
- OP_ACCEPT, /* 225 */
- OP_SHUTDOWN, /* 226 */
- OP_GSOCKOPT, /* 227 */
- OP_SSOCKOPT, /* 228 */
- OP_GETSOCKNAME, /* 229 */
- OP_GETPEERNAME, /* 230 */
- OP_LSTAT, /* 231 */
- OP_STAT, /* 232 */
- OP_FTRREAD, /* 233 */
- OP_FTRWRITE, /* 234 */
- OP_FTREXEC, /* 235 */
- OP_FTEREAD, /* 236 */
- OP_FTEWRITE, /* 237 */
- OP_FTEEXEC, /* 238 */
- OP_FTIS, /* 239 */
- OP_FTEOWNED, /* 240 */
- OP_FTROWNED, /* 241 */
- OP_FTZERO, /* 242 */
- OP_FTSIZE, /* 243 */
- OP_FTMTIME, /* 244 */
- OP_FTATIME, /* 245 */
- OP_FTCTIME, /* 246 */
- OP_FTSOCK, /* 247 */
- OP_FTCHR, /* 248 */
- OP_FTBLK, /* 249 */
- OP_FTFILE, /* 250 */
- OP_FTDIR, /* 251 */
- OP_FTPIPE, /* 252 */
- OP_FTLINK, /* 253 */
- OP_FTSUID, /* 254 */
- OP_FTSGID, /* 255 */
- OP_FTSVTX, /* 256 */
- OP_FTTTY, /* 257 */
- OP_FTTEXT, /* 258 */
- OP_FTBINARY, /* 259 */
- OP_CHDIR, /* 260 */
- OP_CHOWN, /* 261 */
- OP_CHROOT, /* 262 */
- OP_UNLINK, /* 263 */
- OP_CHMOD, /* 264 */
- OP_UTIME, /* 265 */
- OP_RENAME, /* 266 */
- OP_LINK, /* 267 */
- OP_SYMLINK, /* 268 */
- OP_READLINK, /* 269 */
- OP_MKDIR, /* 270 */
- OP_RMDIR, /* 271 */
- OP_OPEN_DIR, /* 272 */
- OP_READDIR, /* 273 */
- OP_TELLDIR, /* 274 */
- OP_SEEKDIR, /* 275 */
- OP_REWINDDIR, /* 276 */
- OP_CLOSEDIR, /* 277 */
- OP_FORK, /* 278 */
- OP_WAIT, /* 279 */
- OP_WAITPID, /* 280 */
- OP_SYSTEM, /* 281 */
- OP_EXEC, /* 282 */
- OP_KILL, /* 283 */
- OP_GETPPID, /* 284 */
- OP_GETPGRP, /* 285 */
- OP_SETPGRP, /* 286 */
- OP_GETPRIORITY, /* 287 */
- OP_SETPRIORITY, /* 288 */
- OP_TIME, /* 289 */
- OP_TMS, /* 290 */
- OP_LOCALTIME, /* 291 */
- OP_GMTIME, /* 292 */
- OP_ALARM, /* 293 */
- OP_SLEEP, /* 294 */
- OP_SHMGET, /* 295 */
- OP_SHMCTL, /* 296 */
- OP_SHMREAD, /* 297 */
- OP_SHMWRITE, /* 298 */
- OP_MSGGET, /* 299 */
- OP_MSGCTL, /* 300 */
- OP_MSGSND, /* 301 */
- OP_MSGRCV, /* 302 */
- OP_SEMGET, /* 303 */
- OP_SEMCTL, /* 304 */
- OP_SEMOP, /* 305 */
- OP_REQUIRE, /* 306 */
- OP_DOFILE, /* 307 */
- OP_ENTEREVAL, /* 308 */
- OP_LEAVEEVAL, /* 309 */
- OP_ENTERTRY, /* 310 */
- OP_LEAVETRY, /* 311 */
- OP_GHBYNAME, /* 312 */
- OP_GHBYADDR, /* 313 */
- OP_GHOSTENT, /* 314 */
- OP_GNBYNAME, /* 315 */
- OP_GNBYADDR, /* 316 */
- OP_GNETENT, /* 317 */
- OP_GPBYNAME, /* 318 */
- OP_GPBYNUMBER, /* 319 */
- OP_GPROTOENT, /* 320 */
- OP_GSBYNAME, /* 321 */
- OP_GSBYPORT, /* 322 */
- OP_GSERVENT, /* 323 */
- OP_SHOSTENT, /* 324 */
- OP_SNETENT, /* 325 */
- OP_SPROTOENT, /* 326 */
- OP_SSERVENT, /* 327 */
- OP_EHOSTENT, /* 328 */
- OP_ENETENT, /* 329 */
- OP_EPROTOENT, /* 330 */
- OP_ESERVENT, /* 331 */
- OP_GPWNAM, /* 332 */
- OP_GPWUID, /* 333 */
- OP_GPWENT, /* 334 */
- OP_SPWENT, /* 335 */
- OP_EPWENT, /* 336 */
- OP_GGRNAM, /* 337 */
- OP_GGRGID, /* 338 */
- OP_GGRENT, /* 339 */
- OP_SGRENT, /* 340 */
- OP_EGRENT, /* 341 */
- OP_GETLOGIN, /* 342 */
- OP_SYSCALL, /* 343 */
+ OP_SYSTELL, /* 208 */
+ OP_SYSSEEK, /* 209 */
+ OP_SYSREAD, /* 210 */
+ OP_SYSWRITE, /* 211 */
+ OP_SEND, /* 212 */
+ OP_RECV, /* 213 */
+ OP_EOF, /* 214 */
+ OP_TELL, /* 215 */
+ OP_SEEK, /* 216 */
+ OP_TRUNCATE, /* 217 */
+ OP_FCNTL, /* 218 */
+ OP_IOCTL, /* 219 */
+ OP_FLOCK, /* 220 */
+ OP_SOCKET, /* 221 */
+ OP_SOCKPAIR, /* 222 */
+ OP_BIND, /* 223 */
+ OP_CONNECT, /* 224 */
+ OP_LISTEN, /* 225 */
+ OP_ACCEPT, /* 226 */
+ OP_SHUTDOWN, /* 227 */
+ OP_GSOCKOPT, /* 228 */
+ OP_SSOCKOPT, /* 229 */
+ OP_GETSOCKNAME, /* 230 */
+ OP_GETPEERNAME, /* 231 */
+ OP_LSTAT, /* 232 */
+ OP_STAT, /* 233 */
+ OP_FTRREAD, /* 234 */
+ OP_FTRWRITE, /* 235 */
+ OP_FTREXEC, /* 236 */
+ OP_FTEREAD, /* 237 */
+ OP_FTEWRITE, /* 238 */
+ OP_FTEEXEC, /* 239 */
+ OP_FTIS, /* 240 */
+ OP_FTEOWNED, /* 241 */
+ OP_FTROWNED, /* 242 */
+ OP_FTZERO, /* 243 */
+ OP_FTSIZE, /* 244 */
+ OP_FTMTIME, /* 245 */
+ OP_FTATIME, /* 246 */
+ OP_FTCTIME, /* 247 */
+ OP_FTSOCK, /* 248 */
+ OP_FTCHR, /* 249 */
+ OP_FTBLK, /* 250 */
+ OP_FTFILE, /* 251 */
+ OP_FTDIR, /* 252 */
+ OP_FTPIPE, /* 253 */
+ OP_FTLINK, /* 254 */
+ OP_FTSUID, /* 255 */
+ OP_FTSGID, /* 256 */
+ OP_FTSVTX, /* 257 */
+ OP_FTTTY, /* 258 */
+ OP_FTTEXT, /* 259 */
+ OP_FTBINARY, /* 260 */
+ OP_CHDIR, /* 261 */
+ OP_CHOWN, /* 262 */
+ OP_CHROOT, /* 263 */
+ OP_UNLINK, /* 264 */
+ OP_CHMOD, /* 265 */
+ OP_UTIME, /* 266 */
+ OP_RENAME, /* 267 */
+ OP_LINK, /* 268 */
+ OP_SYMLINK, /* 269 */
+ OP_READLINK, /* 270 */
+ OP_MKDIR, /* 271 */
+ OP_RMDIR, /* 272 */
+ OP_OPEN_DIR, /* 273 */
+ OP_READDIR, /* 274 */
+ OP_TELLDIR, /* 275 */
+ OP_SEEKDIR, /* 276 */
+ OP_REWINDDIR, /* 277 */
+ OP_CLOSEDIR, /* 278 */
+ OP_FORK, /* 279 */
+ OP_WAIT, /* 280 */
+ OP_WAITPID, /* 281 */
+ OP_SYSTEM, /* 282 */
+ OP_EXEC, /* 283 */
+ OP_KILL, /* 284 */
+ OP_GETPPID, /* 285 */
+ OP_GETPGRP, /* 286 */
+ OP_SETPGRP, /* 287 */
+ OP_GETPRIORITY, /* 288 */
+ OP_SETPRIORITY, /* 289 */
+ OP_TIME, /* 290 */
+ OP_TMS, /* 291 */
+ OP_LOCALTIME, /* 292 */
+ OP_GMTIME, /* 293 */
+ OP_ALARM, /* 294 */
+ OP_SLEEP, /* 295 */
+ OP_SHMGET, /* 296 */
+ OP_SHMCTL, /* 297 */
+ OP_SHMREAD, /* 298 */
+ OP_SHMWRITE, /* 299 */
+ OP_MSGGET, /* 300 */
+ OP_MSGCTL, /* 301 */
+ OP_MSGSND, /* 302 */
+ OP_MSGRCV, /* 303 */
+ OP_SEMGET, /* 304 */
+ OP_SEMCTL, /* 305 */
+ OP_SEMOP, /* 306 */
+ OP_REQUIRE, /* 307 */
+ OP_DOFILE, /* 308 */
+ OP_ENTEREVAL, /* 309 */
+ OP_LEAVEEVAL, /* 310 */
+ OP_ENTERTRY, /* 311 */
+ OP_LEAVETRY, /* 312 */
+ OP_GHBYNAME, /* 313 */
+ OP_GHBYADDR, /* 314 */
+ OP_GHOSTENT, /* 315 */
+ OP_GNBYNAME, /* 316 */
+ OP_GNBYADDR, /* 317 */
+ OP_GNETENT, /* 318 */
+ OP_GPBYNAME, /* 319 */
+ OP_GPBYNUMBER, /* 320 */
+ OP_GPROTOENT, /* 321 */
+ OP_GSBYNAME, /* 322 */
+ OP_GSBYPORT, /* 323 */
+ OP_GSERVENT, /* 324 */
+ OP_SHOSTENT, /* 325 */
+ OP_SNETENT, /* 326 */
+ OP_SPROTOENT, /* 327 */
+ OP_SSERVENT, /* 328 */
+ OP_EHOSTENT, /* 329 */
+ OP_ENETENT, /* 330 */
+ OP_EPROTOENT, /* 331 */
+ OP_ESERVENT, /* 332 */
+ OP_GPWNAM, /* 333 */
+ OP_GPWUID, /* 334 */
+ OP_GPWENT, /* 335 */
+ OP_SPWENT, /* 336 */
+ OP_EPWENT, /* 337 */
+ OP_GGRNAM, /* 338 */
+ OP_GGRGID, /* 339 */
+ OP_GGRENT, /* 340 */
+ OP_SGRENT, /* 341 */
+ OP_EGRENT, /* 342 */
+ OP_GETLOGIN, /* 343 */
+ OP_SYSCALL, /* 344 */
OP_max
} opcode;
-#define MAXO 344
+#define MAXO 345
#ifndef DOINIT
EXT char *op_name[];
"prtf",
"print",
"sysopen",
+ "systell",
"sysseek",
"sysread",
"syswrite",
"printf",
"print",
"sysopen",
+ "systell",
"sysseek",
"sysread",
"syswrite",
OP * pp_prtf _((void));
OP * pp_print _((void));
OP * pp_sysopen _((void));
+OP * pp_systell _((void));
OP * pp_sysseek _((void));
OP * pp_sysread _((void));
OP * pp_syswrite _((void));
pp_prtf,
pp_print,
pp_sysopen,
+ pp_systell,
pp_sysseek,
pp_sysread,
pp_syswrite,
ck_listiob, /* prtf */
ck_listiob, /* print */
ck_fun, /* sysopen */
+ ck_fun, /* systell */
ck_fun, /* sysseek */
ck_fun, /* sysread */
ck_fun, /* syswrite */
0x00002e15, /* prtf */
0x00002e15, /* print */
0x00911604, /* sysopen */
+ 0x00000e0c, /* systell */
0x00011604, /* sysseek */
0x0091761d, /* sysread */
0x0091161d, /* syswrite */
print print ck_listiob ims F? L
sysopen sysopen ck_fun s F S S S?
+systell systell ck_fun st F?
sysseek sysseek ck_fun s F S S
sysread sysread ck_fun imst F R S S?
syswrite syswrite ck_fun imst F S S S?
,"Dev97C - Third development patch to 5.003_97"
,"Dev97D - Fourth development patch to 5.003_97"
,"Dev97E - Fifth development patch to 5.003_97"
+ ,"Dev97F - Sixth development patch to 5.003_97"
,NULL
};
first. Bit eight of each byte is set, except for the last byte, in
which bit eight is clear.
-=item sysseek()
+=item sysseek() and systell()
-This is a variant of seek() that works on the system file pointer.
-It is the only reliable way to seek before sysread() or syswrite().
+These are new. The sysseek() operator is a variant of seek() that works
+on the system file pointer. It is the only reliable way to seek before
+using sysread() or syswrite(). Its companion operator systell() reports
+the current position of the system file pointer.
=item use VERSION
(F) The range specified in a character class had a minimum character
greater than the maximum character. See L<perlre>.
+=item Invalid type in pack: '%s'
+
+(F) The given character is not a valid pack type. See L<perlop/pack>.
+
+=item Invalid type in unpack: '%s'
+
+(F) The given character is not a valid unpack type. See L<perlop/unpack>.
+
=item ioctl is not implemented
(F) Your machine apparently doesn't implement ioctl(), which is pretty
(F) The lexer couldn't find the final delimiter of a // or m{}
construct. Remember that bracketing delimiters count nesting level.
-=item seek() on unopened file
+=item %sseek() on unopened file
-(W) You tried to use the seek() function on a filehandle that was either
-never opened or has since been closed.
+(W) You tried to use the seek() or sysseek() function on a filehandle that
+was either never opened or has since been closed.
=item select not implemented
(W) The filehandle you're writing to got itself closed sometime before now.
Check your logic flow.
-=item tell() on unopened file
+=item %stell() on unopened file
-(W) You tried to use the tell() function on a filehandle that was either
-never opened or has since been closed.
+(W) You tried to use the tell() or systell() function on a filehandle that
+was either never opened or has since been closed.
=item Test on unopened file E<lt>%sE<gt>
binmode, close, closedir, dbmclose, dbmopen, die, eof,
fileno, flock, format, getc, print, printf, read, readdir,
-rewinddir, seek, seekdir, select, syscall, sysread,
-syswrite, tell, telldir, truncate, warn, write
+rewinddir, seek, seekdir, select, syscall, sysread, sysseek,
+systell, syswrite, tell, telldir, truncate, warn, write
=item Functions for fixed length data or records
c A signed char value.
C An unsigned char value.
+
s A signed short value.
S An unsigned short value.
+ (This 'short' is _exactly_ 16 bits, which may differ from
+ what a local C compiler calls 'short'.)
+
i A signed integer value.
I An unsigned integer value.
+ (This 'integer' is _at_least_ 32 bits wide. Its exact size
+ depends on what a local C compiler calls 'int', and may
+ even be larger than the 'long' described in the next item.)
+
l A signed long value.
L An unsigned long value.
+ (This 'long' is _exactly_ 32 bits, which may differ from
+ what a local C compiler calls 'long'.)
- n A short in "network" order.
- N A long in "network" order.
+ n A short in "network" (big-endian) order.
+ N A long in "network" (big-endian) order.
v A short in "VAX" (little-endian) order.
V A long in "VAX" (little-endian) order.
+ (These 'shorts' and 'longs' are _exactly_ 16 bits and
+ _exactly_ 32 bits, respectively.)
f A single-precision float in the native format.
d A double-precision float in the native format.
u A uuencoded string.
- w A BER compressed integer. Bytes give an unsigned integer base
- 128, most significant digit first, with as few digits as
- possible, and with the bit 8 of each byte except the last set
- to "1."
+ w A BER compressed integer. Its bytes represent an unsigned
+ integer in base 128, most significant digit first, with as few
+ digits as possible. Bit eight (the high bit) is set on each
+ byte except the last.
x A null byte.
X Back up a byte.
=item sysread FILEHANDLE,SCALAR,LENGTH
Attempts to read LENGTH bytes of data into variable SCALAR from the
-specified FILEHANDLE, using the system call read(2). It bypasses
-stdio, so mixing this with other kinds of reads or with seek() may
-cause confusion. Returns the number of bytes actually read, or undef
-if there was an error. SCALAR will be grown or shrunk so that the
-last byte actually read is the last byte of the scalar after the read.
+specified FILEHANDLE, using the system call read(2). It bypasses stdio,
+so mixing this with other kinds of reads, print(), write(), seek(), or
+tell() can cause confusion. Returns the number of bytes actually read,
+or undef if there was an error. SCALAR will be grown or shrunk so that
+the last byte actually read is the last byte of the scalar after the
+read.
An OFFSET may be specified to place the read data at some place in the
string other than the beginning. A negative OFFSET specifies
=item sysseek FILEHANDLE,POSITION,WHENCE
Randomly positions the system file pointer for FILEHANDLE using the
-system call lseek(2). It bypasses stdio, so mixing this with read(),
-print(), write(), or seek() may cause confusion. FILEHANDLE may be an
-expression whose value gives the name of the filehandle. The values for
-WHENCE are 0 to set the file pointer to POSITION, 1 to set the it to
-current plus POSITION, and 2 to set it to EOF plus offset. You may use
-the values SEEK_SET, SEEK_CUR, and SEEK_END for this from either the
-IO::Seekable or the POSIX module. Returns 1 upon success, 0 otherwise.
+system call lseek(2). It bypasses stdio, so mixing this with reads
+(other than sysread()), print(), write(), seek(), or tell() may cause
+confusion. FILEHANDLE may be an expression whose value gives the name
+of the filehandle. The values for WHENCE are 0 to set the file pointer
+to POSITION, 1 to set the it to current plus POSITION, and 2 to set it
+to EOF plus offset. You may use the values SEEK_SET, SEEK_CUR, and
+SEEK_END for this from either the IO::Seekable or the POSIX module.
+Returns 1 upon success, 0 otherwise. See also L</systell>.
+
+=item systell FILEHANDLE
+
+=item systell
+
+Returns the current position of the system file pointer for FILEHANDLE
+as reported by the system call lseek(2). It bypasses stdio, so mixing
+this with reads (other than sysread()), print(), write(), seek(), or
+tell() may cause confusion. FILEHANDLE may be an expression whose value
+gives the name of the actual filehandle. If FILEHANDLE is omitted,
+assumes the file last read. See also L</sysseek>.
=item system LIST
Attempts to write LENGTH bytes of data from variable SCALAR to the
specified FILEHANDLE, using the system call write(2). It bypasses
-stdio, so mixing this with prints or with seek() may cause confusion.
-Returns the number of bytes actually written, or undef if there was an
-error. If the length is greater than the available data, only as much
-data as is available will be written.
+stdio, so mixing this with reads (other than sysread()), print(),
+write(), seek(), or tell() may cause confusion. Returns the number of
+bytes actually written, or undef if there was an error. If the length
+is greater than the available data, only as much data as is available
+will be written.
An OFFSET may be specified to write the data from some part of the
string other than the beginning. A negative OFFSET specifies writing
=item New and changed builtin functions
delete on slices, flock, printf and sprintf, keys as an lvalue, my() in
-Control Structures, pack() and unpack(), sysseek(), use VERSION, use Module
-VERSION LIST, prototype(FUNCTION), srand, $_ as Default, C<m//g> does not
-reset search position on failure, C<m//x> ignores whitespace before ?*+{},
-nested C<sub{}> closures work now, formats work right on changing lexicals
+Control Structures, pack() and unpack(), sysseek() and systell(), use
+VERSION, use Module VERSION LIST, prototype(FUNCTION), srand, $_ as
+Default, C<m//g> does not reset search position on failure, C<m//x> ignores
+whitespace before ?*+{}, nested C<sub{}> closures work now, formats work
+right on changing lexicals
=item New builtin methods
symlink OLDFILE,NEWFILE, syscall LIST, sysopen FILEHANDLE,FILENAME,MODE,
sysopen FILEHANDLE,FILENAME,MODE,PERMS, sysread
FILEHANDLE,SCALAR,LENGTH,OFFSET, sysread FILEHANDLE,SCALAR,LENGTH, sysseek
-FILEHANDLE,POSITION,WHENCE, system LIST, syswrite
-FILEHANDLE,SCALAR,LENGTH,OFFSET, syswrite FILEHANDLE,SCALAR,LENGTH, tell
-FILEHANDLE, tell, telldir DIRHANDLE, tie VARIABLE,CLASSNAME,LIST, tied
-VARIABLE, time, times, tr///, truncate FILEHANDLE,LENGTH, truncate
-EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR, ucfirst, umask EXPR, umask, undef
-EXPR, undef, unlink LIST, unlink, unpack TEMPLATE,EXPR, untie VARIABLE,
-unshift ARRAY,LIST, use Module LIST, use Module, use Module VERSION LIST,
-use VERSION, utime LIST, values HASH, vec EXPR,OFFSET,BITS, wait, waitpid
-PID,FLAGS, wantarray, warn LIST, write FILEHANDLE, write EXPR, write, y///
+FILEHANDLE,POSITION,WHENCE, systell FILEHANDLE, systell, system LIST,
+syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET, syswrite
+FILEHANDLE,SCALAR,LENGTH, tell FILEHANDLE, tell, telldir DIRHANDLE, tie
+VARIABLE,CLASSNAME,LIST, tied VARIABLE, time, times, tr///, truncate
+FILEHANDLE,LENGTH, truncate EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR,
+ucfirst, umask EXPR, umask, undef EXPR, undef, unlink LIST, unlink, unpack
+TEMPLATE,EXPR, untie VARIABLE, unshift ARRAY,LIST, use Module LIST, use
+Module, use Module VERSION LIST, use VERSION, utime LIST, values HASH, vec
+EXPR,OFFSET,BITS, wait, waitpid PID,FLAGS, wantarray, warn LIST, write
+FILEHANDLE, write EXPR, write, y///
=back
* floating-point type to use for NV that has adequate bits to fully
* hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
*
- * It just so happens that "int" is the right size everywhere, at
- * least today.
+ * It just so happens that "int" is the right size almost everywhere.
*/
typedef int IBW;
typedef unsigned UBW;
+/*
+ * Mask used after bitwise operations.
+ *
+ * There is at least one realm (Cray word machines) that doesn't
+ * have an integral type (except char) small enough to be represented
+ * in a double without loss; that is, it has no 32-bit type.
+ */
+#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
+# define BWBITS 32
+# define BWMASK ((1 << BWBITS) - 1)
+# define BWSIGN (1 << (BWBITS - 1))
+# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
+# define BWu(u) ((u) & BW_MASK)
+#else
+# define BWi(i) (i)
+# define BWu(u) (u)
+#endif
+
+/*
+ * Offset for integer pack/unpack.
+ *
+ * On architectures where I16 and I32 aren't really 16 and 32 bits,
+ * which for now are all Crays, pack and unpack have to play games.
+ */
+
+/*
+ * These values are required for portability of pack() output.
+ * If they're not right on your machine, then pack() and unpack()
+ * wouldn't work right anyway; you'll need to apply the Cray hack.
+ * (I'd like to check them with #if, but you can't use sizeof() in
+ * the preprocessor.)
+ */
+#define SIZE16 2
+#define SIZE32 4
+
+#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
+# if BYTEORDER == 0x12345678
+# define OFF16(p) (char*)(p)
+# define OFF32(p) (char*)(p)
+# else
+# if BYTEORDER == 0x87654321
+# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
+# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
+# else
+ }}}} bad cray byte order
+# endif
+# endif
+# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
+# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
+# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
+# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
+#else
+# define COPY16(s,p) Copy(s, p, SIZE16, char)
+# define COPY32(s,p) Copy(s, p, SIZE32, char)
+# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
+# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
+#endif
+
static void doencodes _((SV* sv, char* s, I32 len));
static SV* refto _((SV* sv));
static U32 seed _((void));
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
IBW i = TOPi;
- SETi( i << shift );
+ i <<= shift;
+ SETi(BWi(i));
}
else {
UBW u = TOPu;
- SETu( u << shift );
+ u <<= shift;
+ SETu(BWu(u));
}
RETURN;
}
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
IBW i = TOPi;
- SETi( i >> shift );
+ i >>= shift;
+ SETi(BWi(i));
}
else {
UBW u = TOPu;
- SETu( u >> shift );
+ u >>= shift;
+ SETu(BWu(u));
}
RETURN;
}
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
IBW value = SvIV(left) & SvIV(right);
- SETi( value );
+ SETi(BWi(value));
}
else {
UBW value = SvUV(left) & SvUV(right);
- SETu( value );
+ SETu(BWu(value));
}
}
else {
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
- SETi( value );
+ SETi(BWi(value));
}
else {
UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
- SETu( value );
+ SETu(BWu(value));
}
}
else {
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
- SETi( value );
+ SETi(BWi(value));
}
else {
UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
- SETu( value );
+ SETu(BWu(value));
}
}
else {
if (SvNIOKp(sv)) {
if (op->op_private & HINT_INTEGER) {
IBW value = ~SvIV(sv);
- SETi( value );
+ SETi(BWi(value));
}
else {
UBW value = ~SvUV(sv);
- SETu( value );
+ SETu(BWu(value));
}
}
else {
len = (datumtype != '@');
switch(datumtype) {
default:
- break;
+ croak("Invalid type in unpack: '%c'", datumtype);
case '%':
if (len == 1 && pat[-1] != '1')
len = 16;
}
break;
case 's':
- along = (strend - s) / sizeof(I16);
+ along = (strend - s) / SIZE16;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &ashort, 1, I16);
- s += sizeof(I16);
+ COPY16(s, &ashort);
+ s += SIZE16;
culong += ashort;
}
}
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &ashort, 1, I16);
- s += sizeof(I16);
+ COPY16(s, &ashort);
+ s += SIZE16;
sv = NEWSV(38, 0);
sv_setiv(sv, (IV)ashort);
PUSHs(sv_2mortal(sv));
case 'v':
case 'n':
case 'S':
- along = (strend - s) / sizeof(U16);
+ along = (strend - s) / SIZE16;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &aushort, 1, U16);
- s += sizeof(U16);
+ COPY16(s, &aushort);
+ s += SIZE16;
#ifdef HAS_NTOHS
if (datumtype == 'n')
aushort = ntohs(aushort);
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &aushort, 1, U16);
- s += sizeof(U16);
+ COPY16(s, &aushort);
+ s += SIZE16;
sv = NEWSV(39, 0);
#ifdef HAS_NTOHS
if (datumtype == 'n')
}
break;
case 'l':
- along = (strend - s) / sizeof(I32);
+ along = (strend - s) / SIZE32;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &along, 1, I32);
- s += sizeof(I32);
+ COPY32(s, &along);
+ s += SIZE32;
if (checksum > 32)
cdouble += (double)along;
else
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &along, 1, I32);
- s += sizeof(I32);
+ COPY32(s, &along);
+ s += SIZE32;
sv = NEWSV(42, 0);
sv_setiv(sv, (IV)along);
PUSHs(sv_2mortal(sv));
case 'V':
case 'N':
case 'L':
- along = (strend - s) / sizeof(U32);
+ along = (strend - s) / SIZE32;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &aulong, 1, U32);
- s += sizeof(U32);
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
aulong = ntohl(aulong);
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &aulong, 1, U32);
- s += sizeof(U32);
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
aulong = ntohl(aulong);
s += sizeof(Quad_t);
}
sv = NEWSV(42, 0);
- sv_setiv(sv, (IV)aquad);
+ if (aquad >= IV_MIN && aquad <= IV_MAX)
+ sv_setiv(sv, (IV)aquad);
+ else
+ sv_setnv(sv, (double)aquad);
PUSHs(sv_2mortal(sv));
}
break;
s += sizeof(unsigned Quad_t);
}
sv = NEWSV(43, 0);
- sv_setuv(sv, (UV)auquad);
+ if (aquad <= UV_MAX)
+ sv_setuv(sv, (UV)auquad);
+ else
+ sv_setnv(sv, (double)auquad);
PUSHs(sv_2mortal(sv));
}
break;
}
else {
if (checksum < 32) {
- along = (1 << checksum) - 1;
- culong &= (U32)along;
+ aulong = (1 << checksum) - 1;
+ culong &= aulong;
}
- sv_setnv(sv, (double)culong);
+ sv_setuv(sv, (UV)culong);
}
XPUSHs(sv_2mortal(sv));
checksum = 0;
len = 1;
switch(datumtype) {
default:
- break;
+ croak("Invalid type in pack: '%c'", datumtype);
case '%':
DIE("%% may only be used in unpack");
case '@':
#ifdef HAS_HTONS
ashort = htons(ashort);
#endif
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ CAT16(cat, &ashort);
}
break;
case 'v':
#ifdef HAS_HTOVS
ashort = htovs(ashort);
#endif
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ CAT16(cat, &ashort);
}
break;
case 'S':
while (len-- > 0) {
fromstr = NEXTFROM;
ashort = (I16)SvIV(fromstr);
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ CAT16(cat, &ashort);
}
break;
case 'I':
while (len-- > 0) {
fromstr = NEXTFROM;
- auint = U_I(SvNV(fromstr));
+ auint = SvUV(fromstr);
sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
}
break;
case 'N':
while (len-- > 0) {
fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
+ aulong = SvUV(fromstr);
#ifdef HAS_HTONL
aulong = htonl(aulong);
#endif
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ CAT32(cat, &aulong);
}
break;
case 'V':
while (len-- > 0) {
fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
+ aulong = SvUV(fromstr);
#ifdef HAS_HTOVL
aulong = htovl(aulong);
#endif
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ CAT32(cat, &aulong);
}
break;
case 'L':
while (len-- > 0) {
fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ aulong = SvUV(fromstr);
+ CAT32(cat, &aulong);
}
break;
case 'l':
while (len-- > 0) {
fromstr = NEXTFROM;
along = SvIV(fromstr);
- sv_catpvn(cat, (char*)&along, sizeof(I32));
+ CAT32(cat, &along);
}
break;
#ifdef HAS_QUAD
PP(pp_tell)
{
+ return pp_systell(ARGS);
+}
+
+PP(pp_systell)
+{
dSP; dTARGET;
GV *gv;
#!./perl
-print "1..32\n";
+print "1..34\n";
chdir('op') || die "sysio.t: cannot look for myself: $!";
print 'not ' unless ($b eq '#!ererl');
print "ok 30\n";
-# test sysseek
+# test sysseek and systell
sysseek(I, 2, 0);
sysread(I, $b, 3);
print 'not ' unless $b eq 'ere';
print "ok 31\n";
+print 'not ' unless systell(I) == 5;
+print "ok 32\n";
sysseek(I, -2, 1);
sysread(I, $b, 4);
print 'not ' unless $b eq 'rerl';
-print "ok 32\n";
+print "ok 33\n";
+print 'not ' unless systell(I) == 7;
+print "ok 34\n";
close(I);
default: /* not a keyword */
just_a_word: {
GV *gv;
+ SV *sv;
char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
/* Get the rest if it looks like a package qualifier */
s = skipspace(s);
if (*s == '(') {
CLINE;
+ if (gv && GvCVu(gv)) {
+ for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
+ if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
+ s = d + 1;
+ goto its_constant;
+ }
+ }
nextval[nexttoke].opval = yylval.opval;
expect = XOPERATOR;
force_next(WORD);
if (gv && GvCVu(gv)) {
CV* cv = GvCV(gv);
- if (*s == '(') {
- nextval[nexttoke].opval = yylval.opval;
- expect = XTERM;
- force_next(WORD);
- yylval.ival = 0;
- TOKEN('&');
- }
if (lastchar == '-')
warn("Ambiguous use of -%s resolved as -&%s()",
tokenbuf, tokenbuf);
last_lop = oldbufptr;
last_lop_op = OP_ENTERSUB;
/* Check for a constant sub */
- {
- SV *sv = cv_const_sv(cv);
- if (sv) {
- SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
- ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
- yylval.opval->op_private = 0;
- TOKEN(WORD);
- }
+ if ((sv = cv_const_sv(cv))) {
+ its_constant:
+ SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
+ ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
+ yylval.opval->op_private = 0;
+ TOKEN(WORD);
}
/* Resolve to GV now. */
case KEY_sysopen:
LOP(OP_SYSOPEN,XTERM);
- case KEY_sysread:
- LOP(OP_SYSREAD,XTERM);
+ case KEY_systell:
+ UNI(OP_SYSTELL);
case KEY_sysseek:
LOP(OP_SYSSEEK,XTERM);
+ case KEY_sysread:
+ LOP(OP_SYSREAD,XTERM);
+
case KEY_syswrite:
LOP(OP_SYSWRITE,XTERM);
if (strEQ(d,"sysopen")) return -KEY_sysopen;
if (strEQ(d,"sysread")) return -KEY_sysread;
if (strEQ(d,"sysseek")) return -KEY_sysseek;
+ if (strEQ(d,"systell")) return -KEY_systell;
break;
case 8:
if (strEQ(d,"syswrite")) return -KEY_syswrite;
#line 209 "perly.y"
{ copline = yyvsp[-9].ival;
yyval.opval = block_end(yyvsp[-7].ival,
- append_elem(OP_LINESEQ, scalar(yyvsp[-6].opval),
- newSTATEOP(0, yyvsp[-10].pval,
+ newSTATEOP(0, yyvsp[-10].pval,
+ append_elem(OP_LINESEQ, scalar(yyvsp[-6].opval),
newWHILEOP(0, 1, (LOOP*)Nullop,
scalar(yyvsp[-4].opval),
yyvsp[0].opval, scalar(yyvsp[-2].opval))))); }
*
* VMS-specific routines for perl5
*
- * Last revised: 15-Feb-1997 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.3.27
+ * Last revised: 11-Apr-1997 by Charles Bailey bailey@genetics.upenn.edu
+ * Version: 5.3.97c
*/
#include <acedef.h>
* rmesexpand() returns the address of the resultant string if
* successful, and NULL on error.
*/
+static char *do_tounixspec(char *, char *, int);
+
static char *
do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
{
static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
+ char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
char esa[NAM$C_MAXRSS], *cp, *out = NULL;
struct FAB myfab = cc$rms_fab;
struct NAM mynam = cc$rms_nam;
STRLEN speclen;
- unsigned long int retsts, haslower = 0;
+ unsigned long int retsts, haslower = 0, isunix = 0;
if (!filespec || !*filespec) {
set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
else outbuf = __rmsexpand_retbuf;
}
+ if ((isunix = (strchr(filespec,'/') != NULL))) {
+ if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
+ filespec = vmsfspec;
+ }
myfab.fab$l_fna = filespec;
myfab.fab$b_fns = strlen(filespec);
myfab.fab$l_nam = &mynam;
if (defspec && *defspec) {
+ if (strchr(defspec,'/') != NULL) {
+ if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
+ defspec = tmpfspec;
+ }
myfab.fab$l_dna = defspec;
myfab.fab$b_dns = strlen(defspec);
}
if (haslower) __mystrtolower(out);
/* Have we been working with an expanded, but not resultant, spec? */
- if (!mynam.nam$b_rsl) strcpy(outbuf,esa);
+ /* Also, convert back to Unix syntax if necessary. */
+ if (!mynam.nam$b_rsl) {
+ if (isunix) {
+ if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
+ }
+ else strcpy(outbuf,esa);
+ }
+ else if (isunix) {
+ if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
+ strcpy(outbuf,tmpfspec);
+ }
return outbuf;
}
/*}}}*/
** found in the Perl standard distribution.
*/
-static char *do_tounixspec(char *, char *, int);
-
/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
static char *do_fileify_dirspec(char *dir,char *buf,int ts)
{
static void
xs_init()
{
- dXSUB_SYS;
EOH
if (@ARGV) {
$subname =~ s/::/__/g;
print OUT "extern void boot_${subname} _((CV* cv));\n"
}
+ # May not actually be a declaration, so put after other declarations
+ print OUT " dXSUB_SYS;\n";
foreach $ext (@exts) {
my($subname) = $ext;
$subname =~ s/::/__/g;
! ELSE
OPTIMIZE = -Od $(RUNTIME)d -Z7 -D "_DEBUG"
! ENDIF
-LINK_DBG = -pdb:$(*B).pdb
+LINK_DBG = -debug -pdb:none
!ELSE
! IF "$(CCTYPE)" == "MSVC20"
OPTIMIZE = -Od $(RUNTIME) -D "NDEBUG"
! ELSE
-OPTIMIZE = -O2 $(RUNTIME) -D "NDEBUG"
+OPTIMIZE = -Od $(RUNTIME) -D "NDEBUG"
! ENDIF
LINK_DBG = -release
!ENDIF
perl_call_method
perl_call_sv
perl_requirepv
-win32_stat
win32_errno
-win32_stderr
+win32_environ
win32_stdin
win32_stdout
+win32_stderr
win32_ferror
win32_feof
win32_strerror
win32_fprintf
win32_printf
win32_vfprintf
+win32_vprintf
win32_fread
win32_fwrite
win32_fopen
win32_tmpfile
win32_abort
win32_fstat
+win32_stat
win32_pipe
win32_popen
win32_pclose
win32_setmode
-win32_open
-win32_close
+win32_lseek
+win32_tell
win32_dup
win32_dup2
+win32_open
+win32_close
+win32_eof
win32_read
win32_write
win32_spawnvpe
#include "EXTERN.h"
#include "perl.h"
+#include "XSUB.h"
#ifdef __cplusplus
}
EXTERN_C void boot_DynaLoader _((CV* cv));
+static
+XS(w32_GetCurrentDirectory)
+{
+ dXSARGS;
+ SV *sv = sv_newmortal();
+ /* Make one call with zero size - return value is required size */
+ DWORD len = GetCurrentDirectory((DWORD)0,NULL);
+ SvUPGRADE(sv,SVt_PV);
+ SvGROW(sv,len);
+ SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv));
+ /*
+ * If result != 0
+ * then it worked, set PV valid,
+ * else leave it 'undef'
+ */
+ if (SvCUR(sv))
+ SvPOK_on(sv);
+ EXTEND(sp,1);
+ ST(0) = sv;
+ XSRETURN(1);
+}
+
static void
xs_init()
{
char *file = __FILE__;
dXSUB_SYS;
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+ newXS("Win32::GetCurrentDirectory", w32_GetCurrentDirectory, file);
}
extern HANDLE PerlDllHandle;
return (pIOSubSystem->pfnvfprintf(fp, format, args));
}
+DllExport int
+win32_vprintf(const char *format, va_list args)
+{
+ return (pIOSubSystem->pfnvprintf(format, args));
+}
+
DllExport size_t
win32_fread(void *buf, size_t size, size_t count, FILE *fp)
{
return pIOSubSystem->pfnsetmode(fd, mode);
}
+DllExport long
+win32_lseek(int fd, long offset, int origin)
+{
+ return pIOSubSystem->pfnlseek(fd, offset, origin);
+}
+
+DllExport long
+win32_tell(int fd)
+{
+ return pIOSubSystem->pfntell(fd);
+}
+
DllExport int
win32_open(const char *path, int flag, ...)
{
}
DllExport int
+win32_eof(int fd)
+{
+ return pIOSubSystem->pfneof(fd);
+}
+
+DllExport int
win32_dup(int fd)
{
return pIOSubSystem->pfndup(fd);
{
return pIOSubSystem->pfnmkdir(dir); /* just ignore mode */
}
+
DllExport int
win32_rmdir(const char *dir)
{
return pIOSubSystem->pfnrmdir(dir);
}
+
DllExport int
win32_chdir(const char *dir)
{
return pIOSubSystem->pfnchdir(dir);
}
+
DllExport int
win32_spawnvpe(int mode, const char *cmdname,
const char *const *argv, const char *const *envp)
EXT int win32_fprintf(FILE *pf, const char *format, ...);
EXT int win32_printf(const char *format, ...);
EXT int win32_vfprintf(FILE *pf, const char *format, va_list arg);
+EXT int win32_vprintf(const char *format, va_list arg);
EXT size_t win32_fread(void *buf, size_t size, size_t count, FILE *pf);
EXT size_t win32_fwrite(const void *buf, size_t size, size_t count, FILE *pf);
EXT FILE* win32_fopen(const char *path, const char *mode);
#define fprintf win32_fprintf
#define vfprintf win32_vfprintf
#define printf win32_printf
+#define vprintf win32_vprintf
#define fread(buf,size,count,f) win32_fread(buf,size,count,f)
#define fwrite(buf,size,count,f) win32_fwrite(buf,size,count,f)
#define fopen win32_fopen
https://perl5.git.perl.org / perl5.git / commitdiff