lib/Pod/Select.pm Pod-Parser - select portions of POD docs
lib/Pod/Text.pm Pod-Parser - convert POD data to formatted ASCII text
lib/Pod/Text/Color.pm Convert POD data to color ASCII text
+lib/Pod/Text/Overstrike.pm Convert POD data to formatted overstrike text
lib/Pod/Text/Termcap.pm Convert POD data to ASCII text with format escapes
lib/Pod/Usage.pm Pod-Parser - print usage messages
lib/Search/Dict.pm Perform binary search on dictionaries
SV *sv;
PerlLIO_dup2(PerlIO_fileno(fp), fd);
+#ifdef VMS
+ if (fd != PerlIO_fileno(PerlIO_stdin())) {
+ char newname[FILENAME_MAX+1];
+ if (fgetname(fp, newname)) {
+ if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname);
+ if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR", newname);
+ }
+ }
+#endif
LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
(void)SvUPGRADE(sv, SVt_IV);
if test "$1" -lt 2 -o \( "$1" -eq 2 -a \( "$2" -lt 95 -o \( "$2" -eq 95 -a "$3" -lt 2 \) \) \); then
cat >&4 <<EOF
-*** Your cc seems to be gcc and its version seems to be less than 2.95.2.
-*** This is not a good idea since old versions of gcc are known to produce
-*** buggy code when compiling Perl (and no doubt for other programs, too).
+*** Your cc seems to be gcc and its version ($_gcc_version) seems to be
+*** less than 2.95.2. This is not a good idea since old versions of gcc
+*** are known to produce buggy code when compiling Perl (and no doubt for
+*** other programs, too).
***
-*** Therefore, I strongly suggest upgrading your gcc. (Why don't you
-*** use the vendor cc is also a good question. It comes with the operating
+*** Therefore, I strongly suggest upgrading your gcc. (Why don't you use
+*** the vendor cc is also a good question. It comes with the operating
*** system and produces good code.)
Cannot continue, aborting.
*** Note that as of gcc 2.95.2 (19991024) and Perl 5.6.0 (March 2000)
*** if the said Perl is compiled with the said gcc the lib/sdbm test
-*** dumps core (meaning that the SDBM_File is unusable). As this core
-*** dump doesn't happen with the vendor cc, this is most probably
-*** a lingering bug in gcc. Therefore unless you have a better gcc
-*** you are still better off using the vendor cc.
+*** may dump core (meaning that the SDBM_File extension is unusable).
+*** As this core dump never happens with the vendor cc, this is most
+*** probably a lingering bug in gcc. Therefore unless you have a better
+*** gcc installation you are still better off using the vendor cc.
Since you explicitly chose gcc, I assume that you know what are doing.
# Pod::Man -- Convert POD data to formatted *roff input.
-# $Id: Man.pm,v 1.10 2000/11/19 05:46:19 eagle Exp $
+# $Id: Man.pm,v 1.12 2000/12/25 12:56:12 eagle Exp $
#
# Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu>
#
# Perl core and too many things could munge CVS magic revision strings.
# This number should ideally be the same as the CVS revision in podlators,
# however.
-$VERSION = 1.10;
+$VERSION = 1.12;
############################################################################
# If there are double quotes, use an if statement to test for nroff, and for
# nroff output the command followed by the argument in double quotes with
# embedded double quotes doubled. For other formatters, remap paired double
-# quotes to `` and ''.
+# quotes to LQUOTE and RQUOTE.
sub switchquotes {
my $self = shift;
my $command = shift;
# We also have to deal with \*C` and \*C', which are used to add the
# quotes around C<> text, since they may expand to " and if they do this
- # confuses the .SH macros and the like no end.
+ # confuses the .SH macros and the like no end. Expand them ourselves.
+ # If $extra is set, we're dealing with =item, which in most nroff macro
+ # sets requires an extra level of quoting of double quotes.
my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
if (/\"/ || ($c_is_quote && /\\\*\(C[\'\`]/)) {
s/\"/\"\"/g;
my $troff = $_;
$troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
- s/\"/\"\"/g if $extra;
- $troff =~ s/\"/\"\"/g if $extra;
s/\\\*\(C\`/$$self{LQUOTE}/g;
s/\\\*\(C\'/$$self{RQUOTE}/g;
$troff =~ s/\\\*\(C[\'\`]//g;
+ s/\"/\"\"/g if $extra;
+ $troff =~ s/\"/\"\"/g if $extra;
$_ = qq("$_") . ($extra ? " $extra" : '');
$troff = qq("$troff") . ($extra ? " $extra" : '');
return ".if n $command $_\n.el $command $troff\n";
# Pod::Text::Color -- Convert POD data to formatted color ASCII text
-# $Id: Color.pm,v 0.5 1999/09/20 10:15:16 eagle Exp $
+# $Id: Color.pm,v 0.6 2000/12/25 12:52:39 eagle Exp $
#
# Copyright 1999 by Russ Allbery <rra@stanford.edu>
#
@ISA = qw(Pod::Text);
-# Use the CVS revision of this file as its version number.
-($VERSION = (split (' ', q$Revision: 0.5 $ ))[1]) =~ s/\.(\d)$/.0$1/;
+# Don't use the CVS revision as the version, since this module is also in
+# Perl core and too many things could munge CVS magic revision strings.
+# This number should ideally be the same as the CVS revision in podlators,
+# however.
+$VERSION = 0.06;
############################################################################
--- /dev/null
+# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text
+# $Id: Overstrike.pm,v 1.1 2000/12/25 12:51:23 eagle Exp $
+#
+# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000
+# (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>)
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# This was written because the output from:
+#
+# pod2text Text.pm > plain.txt; less plain.txt
+#
+# is not as rich as the output from
+#
+# pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt
+#
+# and because both Pod::Text::Color and Pod::Text::Termcap are not device
+# independent.
+
+############################################################################
+# Modules and declarations
+############################################################################
+
+package Pod::Text::Overstrike;
+
+require 5.004;
+
+use Pod::Text ();
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+@ISA = qw(Pod::Text);
+
+# Don't use the CVS revision as the version, since this module is also in
+# Perl core and too many things could munge CVS magic revision strings.
+# This number should ideally be the same as the CVS revision in podlators,
+# however.
+$VERSION = 1.01;
+
+
+############################################################################
+# Overrides
+############################################################################
+
+# Make level one headings bold, overridding any existing formatting.
+sub cmd_head1 {
+ my $self = shift;
+ local $_ = shift;
+ s/\s+$//;
+ s/(.)\cH\1//g;
+ s/_\cH//g;
+ s/(.)/$1\b$1/g;
+ $self->SUPER::cmd_head1 ($_);
+}
+
+# Make level two headings bold, overriding any existing formatting.
+sub cmd_head2 {
+ my $self = shift;
+ local $_ = shift;
+ s/\s+$//;
+ s/(.)\cH\1//g;
+ s/_\cH//g;
+ s/(.)/$1\b$1/g;
+ $self->SUPER::cmd_head2 ($_);
+}
+
+# Make level three headings underscored, overriding any existing formatting.
+sub cmd_head3 {
+ my $self = shift;
+ local $_ = shift;
+ s/\s+$//;
+ s/(.)\cH\1//g;
+ s/_\cH//g;
+ s/(.)/_\b$1/g;
+ $self->SUPER::cmd_head3 ($_);
+}
+
+# Fix the various interior sequences.
+sub seq_b { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/$1\b$1/g; $_ }
+sub seq_f { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ }
+sub seq_i { local $_ = $_[1]; s/(.)\cH\1//g; s/_\cH//g; s/(.)/_\b$1/g; $_ }
+
+# We unfortunately have to override the wrapping code here, since the normal
+# wrapping code gets really confused by all the escape sequences.
+sub wrap {
+ my $self = shift;
+ local $_ = shift;
+ my $output = '';
+ my $spaces = ' ' x $$self{MARGIN};
+ my $width = $$self{width} - $$self{MARGIN};
+ while (length > $width) {
+ if (s/^((?:(?:[^\n]\cH)?[^\n]){0,$width})\s+//
+ || s/^((?:(?:[^\n]\cH)?[^\n]){$width})//) {
+ $output .= $spaces . $1 . "\n";
+ } else {
+ last;
+ }
+ }
+ $output .= $spaces . $_;
+ $output =~ s/\s+$/\n\n/;
+ $output;
+}
+
+############################################################################
+# Module return value and documentation
+############################################################################
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Text::Overstrike - Convert POD data to formatted overstrike text
+
+=head1 SYNOPSIS
+
+ use Pod::Text::Overstrike;
+ my $parser = Pod::Text::Overstrike->new (sentence => 0, width => 78);
+
+ # Read POD from STDIN and write to STDOUT.
+ $parser->parse_from_filehandle;
+
+ # Read POD from file.pod and write to file.txt.
+ $parser->parse_from_file ('file.pod', 'file.txt');
+
+=head1 DESCRIPTION
+
+Pod::Text::Overstrike is a simple subclass of Pod::Text that highlights
+output text using overstrike sequences, in a manner similar to nroff.
+Characters in bold text are overstruck (character, backspace, character) and
+characters in underlined text are converted to overstruck underscores
+(underscore, backspace, character). This format was originally designed for
+hardcopy terminals and/or lineprinters, yet is readable on softcopy (CRT)
+terminals.
+
+Overstruck text is best viewed by page-at-a-time programs that take
+advantage of the terminal's B<stand-out> and I<underline> capabilities, such
+as the less program on Unix.
+
+Apart from the overstrike, it in all ways functions like Pod::Text. See
+L<Pod::Text> for details and available options.
+
+=head1 BUGS
+
+Currently, the outermost formatting instruction wins, so for example
+underlined text inside a region of bold text is displayed as simply bold.
+There may be some better approach possible.
+
+=head1 SEE ALSO
+
+L<Pod::Text|Pod::Text>, L<Pod::Parser|Pod::Parser>
+
+=head1 AUTHOR
+
+Joe Smith E<lt>Joe.Smith@inwap.comE<gt>, using the framework created by Russ
+Allbery E<lt>rra@stanford.eduE<gt>.
+
+=cut
# Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes.
-# $Id: Termcap.pm,v 0.4 1999/09/20 10:17:45 eagle Exp $
+# $Id: Termcap.pm,v 1.0 2000/12/25 12:52:48 eagle Exp $
#
# Copyright 1999 by Russ Allbery <rra@stanford.edu>
#
@ISA = qw(Pod::Text);
-# Use the CVS revision of this file as its version number.
-($VERSION = (split (' ', q$Revision: 0.4 $ ))[1]) =~ s/\.(\d)$/.0$1/;
+# Don't use the CVS revision as the version, since this module is also in
+# Perl core and too many things could munge CVS magic revision strings.
+# This number should ideally be the same as the CVS revision in podlators,
+# however.
+$VERSION = 1.00;
############################################################################
PL_modcount++;
return o;
case OP_CONST:
+ if (o->op_private & (OPpCONST_BARE) &&
+ !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
+ SV *sv = ((SVOP*)o)->op_sv;
+ GV *gv;
+
+ /* Could be a filehandle */
+ if (gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO)) {
+ OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
+ op_free(o);
+ o = gvio;
+ } else {
+ /* OK, it's a sub */
+ OP* enter;
+ gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
+
+ enter = newUNOP(OP_ENTERSUB,0,
+ newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0, gv)
+ ));
+ enter->op_private |= OPpLVAL_INTRO;
+ op_free(o);
+ o = enter;
+ }
+ break;
+ }
if (!(o->op_private & (OPpCONST_ARYBASE)))
goto nomod;
if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
$options{sentence} = 0;
Getopt::Long::config ('bundling');
GetOptions (\%options, 'alt|a', 'color|c', 'help|h', 'indent|i=i',
- 'loose|l', 'quotes|q=s', 'sentence|s', 'termcap|t',
- 'width|w=i') or exit 1;
+ 'loose|l', 'overstrike|o', 'quotes|q=s', 'sentence|s',
+ 'termcap|t', 'width|w=i') or exit 1;
pod2usage (1) if $options{help};
# Figure out what formatter we're going to use. -c overrides -t.
} elsif ($options{termcap}) {
$formatter = 'Pod::Text::Termcap';
require Pod::Text::Termcap;
+} elsif ($options{overstrike}) {
+ $formatter = 'Pod::Text::Overstrike';
+ require Pod::Text::Overstrike;
}
-delete @options{'color', 'termcap'};
+delete @options{'color', 'termcap', 'overstrike'};
# Initialize and run the formatter.
my $parser = $formatter->new (%options);
=head1 SYNOPSIS
-pod2text [B<-aclst>] [B<-i> I<indent>] [B<-q> I<quotes>] [B<-w> I<width>]
+pod2text [B<-aclost>] [B<-i> I<indent>] [B<-q> I<quotes>] [B<-w> I<width>]
[I<input> [I<output>]]
pod2text B<-h>
because this is the expected formatting for manual pages; if you're
formatting arbitrary text documents, using this option is recommended.
+=item B<-o>, B<--overstrike>
+
+Format the output with overstruck printing. Bold text is rendered as
+character, backspace, character. Italics and file names are rendered as
+underscore, backspace, character. Many pagers, such as B<less>, know how
+to convert this to bold or underlined text.
+
=item B<-q> I<quotes>, B<--quotes>=I<quotes>
Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
char *s, *t, *e;
int hibit = 0;
- if (!sv || !SvPOK(sv) || !SvCUR(sv) || SvUTF8(sv))
+ if (!sv || !SvPOK(sv) || SvUTF8(sv))
return;
/* This function could be much more efficient if we had a FLAG in SVs
/*
=for apidoc sv_catsv
-Concatenates the string from SV C<ssv> onto the end of the string in SV
-C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
+not 'set' magic. See C<sv_catsv_mg>.
-=cut
-*/
+=cut */
void
-Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
+Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
{
- if (!ssv)
+ char *spv;
+ STRLEN slen;
+ if (!sstr)
return;
- else {
- STRLEN slen;
- char *spv;
+ if ((spv = SvPV(sstr, slen))) {
+ bool dutf8 = DO_UTF8(dstr);
+ bool sutf8 = DO_UTF8(sstr);
- if ((spv = SvPV(ssv, slen))) {
- bool dutf8 = DO_UTF8(dsv);
- bool sutf8 = DO_UTF8(ssv);
-
- if (dutf8 != sutf8) {
- STRLEN dlen;
- char *dpv;
- char *d;
-
- /* We may modify dsv but not ssv. */
-
- if (!dutf8)
- sv_utf8_upgrade(dsv);
- dpv = SvPV(dsv, dlen);
- /* Overguestimate on the slen. */
- /* (Why +2 and not +1 is needed?
- * (Try PERL_DESTRUCT_LEVEL=2 ./perl t/op/join.t)
- * Can't figure out right now. --jhi) */
- SvGROW(dsv, dlen + (sutf8 ? 2 * slen : slen) + 2);
- d = dpv + dlen;
- if (dutf8) /* && !sutf8 */ {
- char *s = spv;
- char *send = s + slen;
-
- while (s < send) {
- U8 c = *s++;
-
- if (UTF8_IS_ASCII(c))
- *d++ = c;
- else {
- *d++ = UTF8_EIGHT_BIT_HI(c);
- *d++ = UTF8_EIGHT_BIT_LO(c);
- s++; /* skip the low byte */
- }
- }
- SvCUR(dsv) += s - spv;
- *d = 0;
- }
- else /* !dutf8 (was) && sutf8 */ {
- sv_catpvn(dsv, spv, slen);
- SvUTF8_on(dsv);
- }
+ if (dutf8 == sutf8)
+ sv_catpvn(dstr,spv,slen);
+ else {
+ if (dutf8) {
+ SV* cstr = newSVsv(sstr);
+ char *cpv;
+ STRLEN clen;
+
+ sv_utf8_upgrade(cstr);
+ cpv = SvPV(cstr,clen);
+ sv_catpvn(dstr,cpv,clen);
+ sv_2mortal(cstr);
+ }
+ else {
+ sv_utf8_upgrade(dstr);
+ sv_catpvn(dstr,spv,slen);
+ SvUTF8_on(dstr);
}
- else
- sv_catpvn(dsv, spv, slen);
}
}
}
*/
void
-Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
+Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
{
- sv_catsv(dsv,ssv);
- SvSETMAGIC(dsv);
+ sv_catsv(dstr,sstr);
+ SvSETMAGIC(dstr);
}
/*
*/
void
-Perl_sv_catpv(pTHX_ register SV *sv, register const char *pv)
+Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
{
register STRLEN len;
STRLEN tlen;
char *junk;
- if (!pv)
+ if (!ptr)
return;
junk = SvPV_force(sv, tlen);
- len = strlen(pv);
+ len = strlen(ptr);
SvGROW(sv, tlen + len + 1);
- if (pv == junk)
- pv = SvPVX(sv);
- Move(pv,SvPVX(sv)+tlen,len+1,char);
+ if (ptr == junk)
+ ptr = SvPVX(sv);
+ Move(ptr,SvPVX(sv)+tlen,len+1,char);
SvCUR(sv) += len;
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
*/
void
-Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *pv)
+Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
{
- sv_catpv(sv,pv);
+ sv_catpv(sv,ptr);
SvSETMAGIC(sv);
}
require Fcntl; import Fcntl qw(/^O_/ /^SEEK_/);
}
+use strict;
+our @s;
+our $fail;
+
sub zap {
close(BIG);
unlink("big");
$fail++;
}
+sub offset ($$) {
+ my ($offset_will_be, $offset_want) = @_;
+ my $offset_is = eval $offset_will_be;
+ unless ($offset_is == $offset_want) {
+ print "# bad offset $offset_is, want $offset_want\n";
+ if (unpack("L", pack("L", $offset_want)) == $offset_is) {
+ my $offset_func = ($offset_will_be =~ /^(\w+)/);
+ print "# 32-bit wraparound suspected in $offset_func() since\n";
+ print "# $offset_want cast into 32 bits is $offset_is.\n";
+ }
+ fail;
+ }
+}
+
print "1..17\n";
my $fail = 0;
sysopen(BIG, "big", O_RDONLY) or do { warn "sysopen failed: $!\n"; bye };
-fail unless sysseek(BIG, 4_500_000_000, SEEK_SET) == 4_500_000_000;
+offset('sysseek(BIG, 4_500_000_000, SEEK_SET)', 4_500_000_000);
print "ok 5\n";
-fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000;
+offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
print "ok 6\n";
-fail unless sysseek(BIG, 1, SEEK_CUR) == 4_500_000_001;
+offset('sysseek(BIG, 1, SEEK_CUR)', 4_500_000_001);
print "ok 7\n";
-fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_001;
+offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_001);
print "ok 8\n";
-fail unless sysseek(BIG, -1, SEEK_CUR) == 4_500_000_000;
+offset('sysseek(BIG, -1, SEEK_CUR)', 4_500_000_000);
print "ok 9\n";
-fail unless sysseek(BIG, 0, SEEK_CUR) == 4_500_000_000;
+offset('sysseek(BIG, 0, SEEK_CUR)', 4_500_000_000);
print "ok 10\n";
-fail unless sysseek(BIG, -3, SEEK_END) == 5_000_000_000;
+offset('sysseek(BIG, -3, SEEK_END)', 5_000_000_000);
print "ok 11\n";
-fail unless sysseek(BIG, 0, SEEK_CUR) == 5_000_000_000;
+offset('sysseek(BIG, 0, SEEK_CUR)', 5_000_000_000);
print "ok 12\n";
my $big;
print "ok 14\n";
# 705_032_704 = (I32)5_000_000_000
+# See that we don't have "big" in the 705_... spot:
+# that would mean that we have a wraparound.
fail unless sysseek(BIG, 705_032_704, SEEK_SET);
print "ok 15\n";
print "ok 10\n";
};
-{ my $s = join("", chr(1234),chr(255));
- print "not " unless length($s) == 2 &&
- ord(substr($s,0,1)) == 1234 &&
- ord(substr($s,1,1)) == 255;
+{ my $s = join("", chr(0x1234), chr(0xff));
+ print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
print "ok 11\n";
}
-{ my $s = join(chr(2345), chr(1234),chr(255));
- print "not " unless length($s) == 3 &&
- ord(substr($s,0,1)) == 1234 &&
- ord(substr($s,1,1)) == 2345 &&
- ord(substr($s,2,1)) == 255;
+{ my $s = join(chr(0xff), chr(0x1234), "");
+ print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
print "ok 12\n";
}
-{ my $s = join(chr(2345), chr(1234),chr(3456));
- print "not " unless length($s) == 3 &&
- ord(substr($s,0,1)) == 1234 &&
- ord(substr($s,1,1)) == 2345 &&
- ord(substr($s,2,1)) == 3456;
+{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345));
+ print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}";
print "ok 13\n";
}
-{ my $s = join(chr(255), chr(1234),chr(2345));
- print "not " unless length($s) == 3 &&
- ord(substr($s,0,1)) == 1234 &&
- ord(substr($s,1,1)) == 255 &&
- ord(substr($s,2,1)) == 2345;
+{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe));
+ print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}";
print "ok 14\n";
}
+
}
}
+use strict;
+our @s;
+our $fail;
+
sub zap {
close(BIG);
unlink("big");
$fail++;
}
+sub offset ($$) {
+ my ($offset_will_be, $offset_want) = @_;
+ my $offset_is = eval $offset_will_be;
+ unless ($offset_is == $offset_want) {
+ print "# bad offset $offset_is, want $offset_want\n";
+ if (unpack("L", pack("L", $offset_want)) == $offset_is) {
+ my $offset_func = ($offset_will_be =~ /^(\w+)/);
+ print "# 32-bit wraparound suspected in $offset_func() since\n";
+ print "# $offset_want cast into 32 bits is $offset_is.\n";
+ }
+ fail;
+ }
+}
+
print "1..17\n";
my $fail = 0;
fail unless seek(BIG, 4_500_000_000, $SEEK_SET);
print "ok 5\n";
-fail unless tell(BIG) == 4_500_000_000;
+offset('tell(BIG)', 4_500_000_000);
print "ok 6\n";
fail unless seek(BIG, 1, $SEEK_CUR);
print "ok 7\n";
-fail unless tell(BIG) == 4_500_000_001;
+# If you get 205_032_705 from here it means that
+# your tell() is returning 32-bit values since (I32)4_500_000_001
+# is exactly 205_032_705.
+offset('tell(BIG)', 4_500_000_001);
print "ok 8\n";
fail unless seek(BIG, -1, $SEEK_CUR);
print "ok 9\n";
-fail unless tell(BIG) == 4_500_000_000;
+offset('tell(BIG)', 4_500_000_000);
print "ok 10\n";
fail unless seek(BIG, -3, $SEEK_END);
print "ok 11\n";
-fail unless tell(BIG) == 5_000_000_000;
+offset('tell(BIG)', 5_000_000_000);
print "ok 12\n";
my $big;
print "ok 14\n";
# 705_032_704 = (I32)5_000_000_000
+# See that we don't have "big" in the 705_... spot:
+# that would mean that we have a wraparound.
fail unless seek(BIG, 705_032_704, $SEEK_SET);
print "ok 15\n";
######################### We start with some black magic to print on failure.
-BEGIN { $| = 1; print "1..73\n"; }
+BEGIN { $| = 1; print "1..82\n"; }
END {print "not ok 1\n" unless $loaded;}
use constant 1.01;
$loaded = 1;
test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/;
test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/;
@warnings = ();
+
+
+use constant {
+ THREE => 3,
+ FAMILY => [ qw( John Jane Sally ) ],
+ AGES => { John => 33, Jane => 28, Sally => 3 },
+ RFAM => [ [ qw( John Jane Sally ) ] ],
+ SPIT => sub { shift },
+ PHFAM => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ],
+};
+
+test 74, @{+FAMILY} == THREE;
+test 75, @{+FAMILY} == @{RFAM->[0]};
+test 76, FAMILY->[2] eq RFAM->[0]->[2];
+test 77, AGES->{FAMILY->[1]} == 28;
+test 78, PHFAM->{John} == AGES->{John};
+test 79, PHFAM->[3] == AGES->{FAMILY->[2]};
+test 80, @{+PHFAM} == SPIT->(THREE+1);
+test 81, THREE**3 eq SPIT->(@{+FAMILY}**3);
+test 82, AGES->{FAMILY->[THREE-1]} == PHFAM->[THREE];
-print "1..47\n";
+print "1..49\n";
BEGIN {
chdir 't' if -d 't';
print "# '$newvar'.\nnot " unless $newvar eq "12";
print "ok 47\n";
+# Testing DWIM of foo = bar;
+sub foo : lvalue {
+ $a;
+}
+$a = "not ok 48\n";
+foo = "ok 48\n";
+print $a;
+
+open bar, ">nothing" or die $!;
+bar = *STDOUT;
+print bar "ok 49\n";
+unlink "nothing";
+
}
}
-print "1..109\n";
+print "1..105\n";
my $test = 1;
print "ok $test\n";
$test++; # 105
}
-
-{
- use utf8;
- my @a = map ord, split(/\x{123}/,
- join("", map chr, (1234, 0x123,
- 0x123,
- 23, 0x123,
- 123, 0x123,
- 128, 0x123,
- 255, 0x123,
- 2345)));
- ok "@a", "1234 0 23 123 128 255 2345";
- $test++; # 106
-}
-
-{
- use utf8;
- my @a = map ord, split(/(\x{123})/,
- join("", map chr, (1234, 0x123,
- 0x123,
- 23, 0x123,
- 123, 0x123,
- 128, 0x123,
- 255, 0x123,
- 2345)));
- # 291 is 0x123
- ok "@a", "1234 291 0 291 23 291 123 291 128 291 255 291 2345";
- $test++; # 107 (variant of test 106)
-}
-
-{
- use utf8;
- my @a = map ord, split(//, join("", map chr, (1234, 0xff, 2345)));
- ok "@a", "1234 255 2345";
- $test++; # 108 (variant of test 66)
-}
-
-{
- use utf8;
- my $x = chr(0xff);
- my @a = map ord, split(/$x/, join("", map chr, (1234, 0xff, 2345)));
- ok "@a", "1234 2345";
- $test++; # 109 (variant of test 67)
-}
-
}
/*}}}*/
+/*{{{static void vmssetuserlnm(char *name, char *eqv);
+/* vmssetuserlnm
+ * sets a user-mode logical in the process logical name table
+ * used for redirection of sys$error
+ */
+void
+Perl_vmssetuserlnm(char *name, char *eqv)
+{
+ $DESCRIPTOR(d_tab, "LNM$PROCESS");
+ struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
+ unsigned long int iss, attr = 0;
+ unsigned char acmode = PSL$C_USER;
+ struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
+ {0, 0, 0, 0}};
+ d_name.dsc$a_pointer = name;
+ d_name.dsc$w_length = strlen(name);
+
+ lnmlst[0].buflen = strlen(eqv);
+ lnmlst[0].bufadr = eqv;
+
+ iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
+ if (!(iss&1)) lib$signal(iss);
+}
+/*}}}*/
/*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
fprintf(fp,"$ perl_del = \"delete\"\n");
fprintf(fp,"$ pif = \"if\"\n");
fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
- fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define sys$input 'perl_popen_in'\n");
- fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define sys$error 'perl_popen_err'\n");
+ fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user sys$input 'perl_popen_in'\n");
+ fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user sys$error 'perl_popen_err'\n");
+ fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
fprintf(fp,"$ cmd = perl_popen_cmd\n");
fprintf(fp,"$! --- get rid of global symbols\n");
fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
+ fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
fprintf(fp,"$ perl_on\n");
fprintf(fp,"$ 'cmd\n");
fprintf(fp,"$ perl_status = $STATUS\n");
- fprintf(fp,"$ perl_del 'perl_cfile'\n");
+ fprintf(fp,"$ perl_del 'perl_cfile'\n");
fprintf(fp,"$ perl_exit 'perl_status'\n");
fsync(fileno(fp));
pInfo info;
struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
DSC$K_CLASS_S, symbol};
- struct dsc$descriptor_s d_out = {0, DSC$K_DTYPE_T,
- DSC$K_CLASS_S, out};
struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
DSC$K_CLASS_S, 0};
+
$DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
$DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
+ $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
$DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
/* once-per-program initialization...
info->in_done = TRUE;
info->out_done = TRUE;
info->err_done = TRUE;
+ in[0] = out[0] = err[0] = '\0';
if (*mode == 'r') { /* piping from subroutine */
- in[0] = '\0';
info->out = pipe_infromchild_setup(mbx,out);
if (info->out) {
if (!done) _ckvmssts(sys$clref(pipe_ef));
_ckvmssts(sys$setast(1));
if (!done) _ckvmssts(sys$waitfr(pipe_ef));
- }
+ }
if (info->out->buf) Safefree(info->out->buf);
Safefree(info->out);
Safefree(info);
return Nullfp;
- }
+ }
info->err = pipe_mbxtofd_setup(fileno(stderr), err);
if (info->err) {
}
} else { /* piping to subroutine , mode=w*/
- int melded;
info->in = pipe_tochild_setup(in,mbx);
info->fp = PerlIO_open(mbx, mode);
if (info->in->buf) Safefree(info->in->buf);
Safefree(info->in);
Safefree(info);
- return Nullfp;
+ return Nullfp;
}
- /* if SYS$ERROR == SYS$OUTPUT, use only one mbx */
-
- melded = FALSE;
- fgetname(stderr, err);
- if (strncmp(err,"SYS$ERROR:",10) == 0) {
- fgetname(stdout, out);
- if (strncmp(out,"SYS$OUTPUT:",11) == 0) {
- if (popen_translate("SYS$OUTPUT",out) == popen_translate("SYS$ERROR",err)) {
- melded = TRUE;
- }
- }
- }
info->out = pipe_mbxtofd_setup(fileno(stdout), out);
if (info->out) {
info->out_done = FALSE;
info->out->info = info;
}
- if (!melded) {
- info->err = pipe_mbxtofd_setup(fileno(stderr), err);
- if (info->err) {
- info->err->pipe_done = &info->err_done;
- info->err_done = FALSE;
- info->err->info = info;
- }
- } else {
- err[0] = '\0';
- }
+
+ info->err = pipe_mbxtofd_setup(fileno(stderr), err);
+ if (info->err) {
+ info->err->pipe_done = &info->err_done;
+ info->err_done = FALSE;
+ info->err->info = info;
+ }
}
- d_out.dsc$w_length = strlen(out); /* lib$spawn sets SYS$OUTPUT so can meld*/
symbol[MAX_DCL_SYMBOL] = '\0';
d_symbol.dsc$w_length = strlen(symbol);
_ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
+ strncpy(symbol, out, MAX_DCL_SYMBOL);
+ d_symbol.dsc$w_length = strlen(symbol);
+ _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
p = VMScmd.dsc$a_pointer;
while (*p && *p != '\n') p++;
info->next=open_pipes; /* prepend to list */
open_pipes=info;
_ckvmssts(sys$setast(1));
- _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &d_out, &flags,
+ _ckvmssts(lib$spawn(&vmspipedsc, &nl_desc, &nl_desc, &flags,
0, &info->pid, &info->completion,
0, popen_completion_ast,info,0,0,0));
_ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
_ckvmssts(lib$delete_symbol(&d_sym_in, &table));
_ckvmssts(lib$delete_symbol(&d_sym_err, &table));
-
+ _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
vms_execfree(aTHX);
PL_forkprocess = info->pid;
PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
exit(vaxc$errno);
}
+ if (out != NULL) Perl_vmssetuserlnm("SYS$OUTPUT",out);
+
if (err != NULL) {
if (strcmp(err,"&1") == 0) {
dup2(fileno(stdout), fileno(Perl_debug_log));
+ Perl_vmssetuserlnm("SYS$ERROR","SYS$OUTPUT");
} else {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
exit(vaxc$errno);
}
+ Perl_vmssetuserlnm("SYS$ERROR",err);
}
}
#ifdef ARGPROC_DEBUG
#endif
char * my_getenv_len (const char *, unsigned long *, bool);
int vmssetenv (char *, char *, struct dsc$descriptor_s **);
+void Perl_vmssetuserlnm(char *name, char *eqv);
char * my_crypt (const char *, const char *);
Pid_t my_waitpid (Pid_t, int *, int);
char * my_gconvert (double, int, int, char *);
$ perl_del = "delete"
$ pif = "if"
$! --- define i/o redirection (sys$output set by lib$spawn)
-$ pif perl_popen_in .nes. "" then perl_define sys$input 'perl_popen_in'
-$ pif perl_popen_err .nes. "" then perl_define sys$error 'perl_popen_err'
+$ pif perl_popen_in .nes. "" then perl_define/user sys$input 'perl_popen_in'
+$ pif perl_popen_err .nes. "" then perl_define/user sys$error 'perl_popen_err'
+$ pif perl_popen_out .nes. "" then perl_define sys$output 'perl_popen_out'
$ cmd = perl_popen_cmd
$! --- get rid of global symbols
$ perl_del/symbol/global perl_popen_in
$ perl_del/symbol/global perl_popen_err
+$ perl_del/symbol/global perl_popen_out
$ perl_del/symbol/global perl_popen_cmd
$ perl_on
$ 'cmd
https://perl5.git.perl.org / perl5.git / commitdiff