summaryrefslogtreecommitdiff
path: root/vms/ext
diff options
context:
space:
mode:
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>1996-12-19 16:44:00 +1200
committerChip Salzenberg <chip@atlantic.net>1996-12-19 16:44:00 +1200
commit5f05dabc4054964aa3b10f44f8468547f051cdf8 (patch)
tree7bcc2c7b6d5cf44e7f0111bac2240ca979d9c804 /vms/ext
parent6a3992aa749356d657a4c0e14be8c2f4c2f4f999 (diff)
downloadperl-5f05dabc4054964aa3b10f44f8468547f051cdf8.tar.gz
[inseparable changes from patch from perl5.003_11 to perl5.003_12]
CORE LANGUAGE CHANGES Subject: Support C<delete @hash{@keys}> From: Chip Salzenberg <chip@atlantic.net> Files: op.c op.h opcode.pl pod/perldiag.pod pod/perlfunc.pod pp.c t/op/delete.t Subject: Autovivify scalars From: Chip Salzenberg <chip@atlantic.net> Files: dump.c op.c op.h pp.c pp_hot.c DOCUMENTATION Subject: Update pods: perldelta -> perlnews, perli18n -> perllocale From: Tom Christiansen <tchrist@perl.com> Files: MANIFEST pod/perl.pod pod/perldelta.pod pod/perli18n.pod pod/perlnews.pod Subject: perltoot.pod Date: Mon, 09 Dec 1996 07:44:10 -0700 From: Tom Christiansen <tchrist@mox.perl.com> Files: MANIFEST pod/perltoot.pod Msg-ID: <199612091444.HAA09947@toy.perl.com> (applied based on p5p patch as commit 32e22efaa9ec59b73a208b6c532a0b435e2c6462) Subject: Perlguts, version 25 Date: Fri, 6 Dec 96 11:40:27 PST From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> Files: pod/perlguts.pod private-msgid: <199612061940.AA055461228@hpcc123.corp.hp.com> Subject: pod patches for English errors Date: Mon, 09 Dec 1996 13:33:11 -0800 From: Steve Kelem <steve.kelem@xilinx.com> Files: pod/*.pod Msg-ID: <24616.850167191@castor> (applied based on p5p patch as commit 0135f10892ed8a21c4dbd1fca21fbcc365df99dd) Subject: Misc doc updates Date: Sat, 14 Dec 1996 18:56:33 -0700 From: Tom Christiansen <tchrist@mox.perl.com> Files: pod/* Subject: Re: perldelta.pod Here are some diffs to the _11 pods. I forgot to add perldelta to perl.pod though. And *PLEASE* fix the Artistic License so it no longer has the bogus "whomever" misdeclined in the nominative case: under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this It should obviously be "whoever". p5p-msgid: <199612150156.SAA12506@mox.perl.com> OTHER CORE CHANGES Subject: Allow assignment to empty array values during foreach() From: Chip Salzenberg <chip@atlantic.net> Files: cop.h global.sym mg.c op.c perl.h pp_hot.c proto.h sv.c Subject: Fix nested closures From: Chip Salzenberg <chip@atlantic.net> Files: op.c opcode.pl pp.c pp_ctl.c pp_hot.c Subject: Fix core dump on auto-vivification From: Chip Salzenberg <chip@atlantic.net> Files: pp_hot.c Subject: Fix core dump on C<open $undef_var, "X"> From: Chip Salzenberg <chip@atlantic.net> Files: pp_sys.c Subject: Fix -T/-B on globs and globrefs From: Chip Salzenberg <chip@atlantic.net> Files: pp_sys.c Subject: Fix memory management of $`, $&, and $' From: Chip Salzenberg <chip@atlantic.net> Files: pp_hot.c regexec.c Subject: Fix paren matching during backtracking From: Chip Salzenberg <chip@atlantic.net> Files: regexec.c Subject: Fix memory leak and std{in,out,err} death in perl_{con,de}str From: Chip Salzenberg <chip@atlantic.net> Files: miniperlmain.c perl.c perl.h sv.c Subject: Discard garbage bytes at end of prototype() From: Chip Salzenberg <chip@atlantic.net> Files: pp.c Subject: Fix local($pack::{foo}) From: Chip Salzenberg <chip@atlantic.net> Files: global.sym pp.c pp_hot.c proto.h scope.c Subject: Disable warn, die, and parse hooks _before_ global destruction From: Chip Salzenberg <chip@atlantic.net> Files: perl.c Subject: Re: Bug in formline Date: Sun, 08 Dec 1996 14:58:32 -0500 From: Gurusamy Sarathy <gsar@engin.umich.edu> Files: pp_ctl.c Msg-ID: <199612081958.OAA26025@aatma.engin.umich.edu> (applied based on p5p patch as commit b386bda18108ba86d0b76ebe2d8745eafa80f39e) Subject: Fix C<@a = ($a,$b,$c,$d) = (1,2)> From: Chip Salzenberg <chip@atlantic.net> Files: pp_hot.c Subject: Properly support and document newRV{,_inc,_noinc} From: Chip Salzenberg <chip@atlantic.net> Files: global.sym pod/perlguts.pod sv.c sv.h Subject: Allow lvalue pos inside recursive function From: Chip Salzenberg <chip@atlantic.net> Files: op.c pp.c pp_ctl.c pp_hot.c PORTABILITY Subject: Make $privlib contents compatible with 5.003 From: Chip Salzenberg <chip@atlantic.net> Files: INSTALL ext/Opcode/Safe.pm installperl lib/FileHandle.pm lib/Test/Harness.pm Subject: Support $bincompat3 config variable; update metaconfig units From: Chip Salzenberg <chip@atlantic.net> Files: Configure MANIFEST compat3.sym config_h.SH embed.pl global.sym old_embed.pl old_global.sym old_perl_exp.SH perl_exp.SH Subject: Look for gettimeofday() in Configure Date: Wed, 11 Dec 1996 15:49:57 +0100 From: John Hughes <john@AtlanTech.COM> Files: Configure config_H config_h.SH pp.c Subject: perl5.003_11, Should base use of gettimeofday on HAS_GETTIMEOFDAY, not I_SYS_TIME I've been installing perl5.003_11 on a SCO system that has the TCP/IP runtime installed but not the TCP/IP development system. Unfortunately the <sys/time.h> include file is included in the TCP/IP runtime while libsocket.a is in the development system. This means that pp.c decides to use "gettimeofday" because <sys/time.h> is present but I can't link the perl that gets compiled. So, here's a patch to base the use of "gettimeofday" on "HAS_GETTIMEOFDAY" instead of "I_SYS_TIME". I also took the liberty of removing the special case for plan9 (I assume plan9 has <sys/time.h> but no gettimeofday. Am I right?). p5p-msgid: <01BBE77A.F6F37F80@malvinas.AtlanTech.COM> Subject: Make $startperl a relative path if people want portable scrip From: Chip Salzenberg <chip@atlantic.net> Files: Configure Subject: Homogenize use of "eval exec" hack From: Chip Salzenberg <chip@atlantic.net> Files: Porting/Glossary eg/README eg/nih eg/sysvipc/ipcmsg eg/sysvipc/ipcsem eg/sysvipc/ipcshm lib/diagnostics.pm makeaperl.SH pod/checkpods.PL pod/perlrun.pod pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL utils/c2ph.PL utils/h2ph.PL utils/h2xs.PL utils/perlbug.PL utils/perldoc.PL utils/pl2pm.PL x2p/a2py.c x2p/find2perl.PL x2p/s2p.PL Subject: LynxOS support Date: Thu, 12 Dec 1996 09:25:00 PST From: Greg Seibert <seibert@Lynx.COM> Files: Configure MANIFEST hints/lynxos.sh t/op/stat.t Msg-ID: <m0vYEsY-0000IZC@kzinti.lynx.com> (applied based on p5p patch as commit 6693373533b15e559fd8f0f1877e5e6ec15483cc) Subject: Re: db-recno.t failures with _11 on Freebsd 2.1-stable Date: 11 Dec 1996 18:58:56 -0500 From: Roderick Schertler <roderick@gate.net> Files: INSTALL hints/freebsd.sh Msg-ID: <pzohg0r5tr.fsf@eeyore.ibcinc.com> (applied based on p5p patch as commit 10e40321ee752c58e3407b204c74c8049894cb51) Subject: VMS patches to 5.003_11 Date: Mon, 09 Dec 1996 23:16:10 -0500 (EST) From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> Files: MANIFEST regexec.c t/lib/filehand.t util.c vms/* private-msgid: <01ICTR32LCZG001A1D@hmivax.humgen.upenn.edu> TESTING Subject: recurse recurse recurse ... Date: Mon, 9 Dec 1996 23:44:27 +0200 (EET) From: Jarkko Hietaniemi <jhi@cc.hut.fi> Files: MANIFEST t/op/recurse.t private-msgid: <199612092144.XAA29025@alpha.hut.fi> UTILITIES, LIBRARY, AND EXTENSIONS Subject: Add CPAN and Net::FTP From: Chip Salzenberg <chip@atlantic.net> Files: MANIFEST lib/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm lib/Net/FTP.pm lib/Net/Netrc.pm lib/Net/Socket.pm pod/perlmod.pod Subject: Add File::Compare Date: Mon, 16 Dec 1996 18:44:59 GMT From: Nick Ing-Simmons <nik@tiuk.ti.com> Files: MANIFEST lib/File/Compare.pm pod/perlmod.pod Msg-ID: <199612161844.SAA02152@pluto> (applied based on p5p patch as commit ec971c5c328aca84fb827f69f2cc1dc3be81f830) Subject: Add Tie::RefHash Date: Sun, 15 Dec 1996 18:58:08 -0500 From: Gurusamy Sarathy <gsar@engin.umich.edu> Files: MANIFEST lib/Tie/RefHash.pm pod/perlmod.pod Msg-ID: <199612152358.SAA28665@aatma.engin.umich.edu> (applied based on p5p patch as commit 9a079709134ebbf4c935cc8752fdb564e5c82b94) Subject: Put "splain" in utils. From: Chip Salzenberg <chip@atlantic.net> Files: Makefile.SH installperl utils/Makefile utils/splain.PL Subject: Some h2ph fixes Date: Fri, 13 Dec 1996 11:34:12 -0800 From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> Files: utils/h2ph.PL Here is a message regarding changes to h2ph that should probably be folded into the 5.004 release. p5p-msgid: <199612131934.AA289845652@hpcc123.corp.hp.com>
Diffstat (limited to 'vms/ext')
-rw-r--r--vms/ext/DCLsym/0README.txt21
-rw-r--r--vms/ext/DCLsym/DCLsym.pm268
-rw-r--r--vms/ext/DCLsym/DCLsym.xs151
-rw-r--r--vms/ext/DCLsym/Makefile.PL3
-rw-r--r--vms/ext/DCLsym/test.pl41
-rw-r--r--vms/ext/Stdio/Stdio.pm21
-rw-r--r--vms/ext/Stdio/Stdio.xs4
-rw-r--r--vms/ext/Stdio/test.pl23
8 files changed, 509 insertions, 23 deletions
diff --git a/vms/ext/DCLsym/0README.txt b/vms/ext/DCLsym/0README.txt
new file mode 100644
index 0000000000..9dc721d36b
--- /dev/null
+++ b/vms/ext/DCLsym/0README.txt
@@ -0,0 +1,21 @@
+VMS::DCLsym is an extension to Perl 5 which allows it to manipulate DCL symbols
+via an object-oriented or tied-hash interface.
+
+In order to build the extension, just say
+
+$ Perl Makefile.PL
+$ MMK
+
+in the directory containing the source files. Once it's built, you can run the
+test script by saying
+
+$ Perl "-Iblib" test.pl
+
+Finally, if you want to make it part of your regular Perl library, you can say
+$ MMK install
+
+If you have any problems or suggestions, please feel free to let me know.
+
+Regards,
+Charles Bailey bailey@genetics.upenn.edu
+17-Aug-1995
diff --git a/vms/ext/DCLsym/DCLsym.pm b/vms/ext/DCLsym/DCLsym.pm
new file mode 100644
index 0000000000..057951dd99
--- /dev/null
+++ b/vms/ext/DCLsym/DCLsym.pm
@@ -0,0 +1,268 @@
+package VMS::DCLsym;
+
+use Carp;
+use DynaLoader;
+use vars qw( @ISA $VERSION );
+use strict;
+
+# Package globals
+@ISA = ( 'DynaLoader' );
+$VERSION = '1.01';
+my(%Locsyms) = ( ':ID' => 'LOCAL' );
+my(%Gblsyms) = ( ':ID' => 'GLOBAL');
+my $DoCache = 1;
+my $Cache_set = 0;
+
+
+#====> OO methods
+
+sub new {
+ my($pkg,$type) = @_;
+ bless { TYPE => $type }, $pkg;
+}
+
+sub DESTROY { }
+
+sub getsym {
+ my($self,$name) = @_;
+ my($val,$table);
+
+ if (($val,$table) = _getsym($name)) {
+ if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; }
+ else { $Locsyms{$name} = $val; }
+ }
+ wantarray ? ($val,$table) : $val;
+}
+
+sub setsym {
+ my($self,$name,$val,$table) = @_;
+
+ $table = $self->{TYPE} unless $table;
+ if (_setsym($name,$val,$table)) {
+ if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; }
+ else { $Locsyms{$name} = $val; }
+ 1;
+ }
+ else { 0; }
+}
+
+sub delsym {
+ my($self,$name,$table) = @_;
+
+ $table = $self->{TYPE} unless $table;
+ if (_delsym($name,$table)) {
+ if ($table eq 'GLOBAL') { delete $Gblsyms{$name}; }
+ else { delete $Locsyms{$name}; }
+ 1;
+ }
+ else { 0; }
+}
+
+sub clearcache {
+ my($self,$perm) = @_;
+ my($old);
+
+ $Cache_set = 0;
+ %Locsyms = ( ':ID' => 'LOCAL');
+ %Gblsyms = ( ':ID' => 'GLOBAL');
+ $old = $DoCache;
+ $DoCache = $perm if defined($perm);
+ $old;
+}
+
+#====> TIEHASH methods
+
+sub TIEHASH {
+ $_[0]->new(@_);
+}
+
+sub FETCH {
+ my($self,$name) = @_;
+ if ($name eq ':GLOBAL') { $self->{TYPE} eq 'GLOBAL'; }
+ elsif ($name eq ':LOCAL' ) { $self->{TYPE} eq 'LOCAL'; }
+ else { scalar($self->getsym($name)); }
+}
+
+sub STORE {
+ my($self,$name,$val) = @_;
+ if ($name eq ':GLOBAL') { $self->{TYPE} = 'GLOBAL'; }
+ elsif ($name eq ':LOCAL' ) { $self->{TYPE} = 'LOCAL'; }
+ else { $self->setsym($name,$val); }
+}
+
+sub DELETE {
+ my($self,$name) = @_;
+
+ $self->delsym($name);
+}
+
+sub FIRSTKEY {
+ my($self) = @_;
+ my($name,$eqs,$val);
+
+ if (!$DoCache || !$Cache_set) {
+ # We should eventually replace this with a C routine which walks the
+ # CLI symbol table directly. If I ever get 'hold of an I&DS manual . . .
+ open(P,'Show Symbol * |');
+ while (<P>) {
+ ($name,$eqs,$val) = /^\s+(\S+) (=+) (.+)/
+ or carp "VMS::CLISym: unparseable line $_";
+ $name =~ s#\*##;
+ $val =~ s/"(.*)"$/$1/ or $val =~ s/^(\S+).*/$1/;
+ if ($eqs eq '==') { $Gblsyms{$name} = $val; }
+ else { $Locsyms{$name} = $val; }
+ }
+ close P;
+ $Cache_set = 1;
+ }
+ $self ->{IDX} = 0;
+ $self->{CACHE} = $self->{TYPE} eq 'GLOBAL' ? \%Gblsyms : \%Locsyms;
+ while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) {
+ if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; }
+ $self->{CACHE} = \%Gblsyms;
+ }
+ $name;
+}
+
+sub NEXTKEY {
+ my($self) = @_;
+ my($name,$val);
+
+ while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) {
+ if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; }
+ $self->{CACHE} = \%Gblsyms;
+ }
+ $name;
+}
+
+
+sub EXISTS { defined($_[0]->FETCH(@_)) ? 1 : 0 }
+
+sub CLEAR { }
+
+
+bootstrap VMS::DCLsym;
+
+1;
+
+__END__
+
+=head1 NAME
+
+VMS::DCLsym - Perl extension to manipulate DCL symbols
+
+=head1 SYNOPSIS
+
+ tie %allsyms, VMS::DCLsym;
+ tie %cgisyms, VMS::DCLsym, 'GLOBAL';
+
+
+ $handle = new VMS::DCLsyms;
+ $value = $handle->getsym($name);
+ $handle->setsym($name,$value,'GLOBAL') or die "Can't create symbol: $!\n";
+ $handle->delsym($name,'LOCAL') or die "Can't delete symbol: $!\n";
+ $handle->clearcache();
+
+=head1 DESCRIPTION
+
+The VMS::DCLsym extension provides access to DCL symbols using a
+tied hash interface. This allows Perl scripts to manipulate symbols in
+a manner similar to the way in which logical names are manipulated via
+the built-in C<%ENV> hash. Alternatively, one can call methods in this
+package directly to read, create, and delete symbols.
+
+=head2 Tied hash interface
+
+This interface lets you treat the DCL symbol table as a Perl associative array,
+in which the key of each element is the symbol name, and the value of the
+element is that symbol's value. Case is not significant in the key string, as
+DCL converts symbol names to uppercase, but it is significant in the value
+string. All of the usual operations on associative arrays are supported.
+Reading an element retrieves the current value of the symbol, assigning to it
+defines a new symbol (or overwrites the old value of an existing symbol), and
+deleting an element deletes the corresponding symbol. Setting an element to
+C<undef>, or C<undef>ing it directly, sets the corresponding symbol to the null
+string. You may also read the special keys ':GLOBAL' and ':LOCAL' to find out
+whether a default symbol table has been specified for this hash (see C<table>
+below), or set either or these keys to specify a default symbol table.
+
+When you call the C<tie> function to bind an associative array to this package,
+you may specify as an optional argument the symbol table in which you wish to
+create and delete symbols. If the argument is the string 'GLOBAL', then the
+global symbol table is used; any other string causes the local symbol table to
+be used. Note that this argument does not affect attempts to read symbols; if
+a symbol with the specified name exists in the local symbol table, it is always
+returned in preference to a symbol by the same name in the global symbol table.
+
+=head2 Object interface
+
+Although it's less convenient in some ways than the tied hash interface, you
+can also call methods directly to manipulate individual symbols. In some
+cases, this allows you finer control than using a tied hash aggregate. The
+following methods are supported:
+
+=item new
+
+This creates a C<VMS::DCLsym> object which can be used as a handle for later
+method calls. The single optional argument specifies the symbol table used
+by default in future method calls, in the same way as the optional argument to
+C<tie> described above.
+
+=item getsym
+
+If called in a scalar context, C<getsym> returns the value of the symbol whose
+name is given as the argument to the call, or C<undef> if no such symbol
+exists. Symbols in the local symbol table are always used in preference to
+symbols in the global symbol table. If called in an array context, C<getsym>
+returns a two-element list, whose first element is the value of the symbol, and
+whose second element is the string 'GLOBAL' or 'LOCAL', indicating the table
+from which the symbol's value was read.
+
+=item setsym
+
+The first two arguments taken by this method are the name of the symbol and the
+value which should be assigned to it. The optional third argument is a string
+specifying the symbol table to be used; 'GLOBAL' specifies the global symbol
+table, and any other string specifies the local symbol table. If this argument
+is omitted, the default symbol table for the object is used. C<setsym> returns
+TRUE if successful, and FALSE otherwise.
+
+=item delsym
+
+This method deletes the symbol whose name is given as the first argument. The
+optional second argument specifies the symbol table, as described above under
+C<setsym>. It returns TRUE if the symbol was successfully deleted, and FALSE
+if it was not.
+
+=item clearcache
+
+Because of the overhead associated with obtaining the list of defined symbols
+for the tied hash iterator, it is only done once, and the list is reused for
+subsequent iterations. Changes to symbols made through this package are
+recorded, but in the rare event that someone changes the process' symbol table
+from outside (as is possible using some software from the net), the iterator
+will be out of sync with the symbol table. If you expect this to happen, you
+can reset the cache by calling this method. In addition, if you pass a FALSE
+value as the first argument, caching will be disabled. It can be reenabled
+later by calling C<clearcache> again with a TRUE value as the first argument.
+It returns TRUE or FALSE to indicate whether caching was previously enabled or
+disabled, respectively.
+
+This method is a stopgap until we can incorporate code into this extension to
+traverse the process' symbol table directly, so it may disappear in a future
+version of this package.
+
+=head1 AUTHOR
+
+Charles Bailey bailey@genetics.upenn.edu
+
+=head1 VERSION
+
+1.01 08-Dec-1996
+
+=head1 BUGS
+
+The list of symbols for the iterator is assembled by spawning off a
+subprocess, which can be slow. Ideally, we should just traverse the
+process' symbol table directly from C.
+
diff --git a/vms/ext/DCLsym/DCLsym.xs b/vms/ext/DCLsym/DCLsym.xs
new file mode 100644
index 0000000000..3918eb11e5
--- /dev/null
+++ b/vms/ext/DCLsym/DCLsym.xs
@@ -0,0 +1,151 @@
+/* VMS::DCLsym - manipulate DCL symbols
+ *
+ * Version: 1.0
+ * Author: Charles Bailey bailey@genetics.upenn.edu
+ * Revised: 17-Aug-1995
+ *
+ *
+ * Revision History:
+ *
+ * 1.0 17-Aug-1995 Charles Bailey bailey@genetics.upenn.edu
+ * original production version
+ */
+
+#include <descrip.h>
+#include <lib$routines.h>
+#include <libclidef.h>
+#include <libdef.h>
+#include <ssdef.h>
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+MODULE = VMS::DCLsym PACKAGE = VMS::DCLsym
+
+void
+_getsym(name)
+ SV * name
+ PPCODE:
+ {
+ struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
+ valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
+ STRLEN namlen;
+ int tbltype;
+ unsigned long int retsts;
+ SETERRNO(0,SS$_NORMAL);
+ if (!name) {
+ PUSHs(sv_newmortal());
+ SETERRNO(EINVAL,LIB$_INVARG);
+ return;
+ }
+ namdsc.dsc$a_pointer = SvPV(name,namlen);
+ namdsc.dsc$w_length = (unsigned short int) namlen;
+ retsts = lib$get_symbol(&namdsc,&valdsc,0,&tbltype);
+ if (retsts & 1) {
+ PUSHs(sv_2mortal(newSVpv(valdsc.dsc$w_length ?
+ valdsc.dsc$a_pointer : "",valdsc.dsc$w_length)));
+ if (GIMME) {
+ EXTEND(sp,2); /* just in case we're at the end of the stack */
+ if (tbltype == LIB$K_CLI_LOCAL_SYM)
+ PUSHs(sv_2mortal(newSVpv("LOCAL",5)));
+ else
+ PUSHs(sv_2mortal(newSVpv("GLOBAL",6)));
+ }
+ _ckvmssts(lib$sfree1_dd(&valdsc));
+ }
+ else {
+ ST(0) = &sv_undef; /* error - we're returning undef, if anything */
+ switch (retsts) {
+ case LIB$_NOSUCHSYM:
+ break; /* nobody home */;
+ case LIB$_INVSYMNAM: /* user errors; set errno return undef */
+ case LIB$_INSCLIMEM:
+ case LIB$_NOCLI:
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ break;
+ default: /* bail out */
+ { _ckvmssts(retsts); }
+ }
+ }
+ }
+
+
+void
+_setsym(name,val,typestr="LOCAL")
+ SV * name
+ SV * val
+ char * typestr
+ CODE:
+ {
+ struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
+ valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
+ STRLEN slen;
+ int type;
+ unsigned long int retsts;
+ SETERRNO(0,SS$_NORMAL);
+ if (!name || !val) {
+ SETERRNO(EINVAL,LIB$_INVARG);
+ XSRETURN_UNDEF;
+ }
+ namdsc.dsc$a_pointer = SvPV(name,slen);
+ namdsc.dsc$w_length = (unsigned short int) slen;
+ valdsc.dsc$a_pointer = SvPV(val,slen);
+ valdsc.dsc$w_length = (unsigned short int) slen;
+ type = strNE(typestr,"GLOBAL") ?
+ LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
+ retsts = lib$set_symbol(&namdsc,&valdsc,&type);
+ if (retsts & 1) { XSRETURN_YES; }
+ else {
+ switch (retsts) {
+ case LIB$_AMBSYMDEF: /* user errors; set errno and return */
+ case LIB$_INSCLIMEM:
+ case LIB$_INVSYMNAM:
+ case LIB$_NOCLI:
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ XSRETURN_NO;
+ break; /* NOTREACHED */
+ default: /* bail out */
+ { _ckvmssts(retsts); }
+ }
+ }
+ }
+
+
+void
+_delsym(name,typestr="LOCAL")
+ SV * name
+ char * typestr
+ CODE:
+ {
+ struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
+ STRLEN slen;
+ int type;
+ unsigned long int retsts;
+ SETERRNO(0,SS$_NORMAL);
+ if (!name || !typestr) {
+ SETERRNO(EINVAL,LIB$_INVARG);
+ XSRETURN_UNDEF;
+ }
+ namdsc.dsc$a_pointer = SvPV(name,slen);
+ namdsc.dsc$w_length = (unsigned short int) slen;
+ type = strNE(typestr,"GLOBAL") ?
+ LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
+ retsts = lib$delete_symbol(&namdsc,&type);
+ if (retsts & 1) { XSRETURN_YES; }
+ else {
+ switch (retsts) {
+ case LIB$_INVSYMNAM: /* user errors; set errno and return */
+ case LIB$_NOCLI:
+ case LIB$_NOSUCHSYM:
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ XSRETURN_NO;
+ break; /* NOTREACHED */
+ default: /* bail out */
+ { _ckvmssts(retsts); }
+ }
+ }
+ }
+
diff --git a/vms/ext/DCLsym/Makefile.PL b/vms/ext/DCLsym/Makefile.PL
new file mode 100644
index 0000000000..8e6f5bce40
--- /dev/null
+++ b/vms/ext/DCLsym/Makefile.PL
@@ -0,0 +1,3 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm' );
diff --git a/vms/ext/DCLsym/test.pl b/vms/ext/DCLsym/test.pl
new file mode 100644
index 0000000000..57f2afbd20
--- /dev/null
+++ b/vms/ext/DCLsym/test.pl
@@ -0,0 +1,41 @@
+print "1..15\n";
+
+require VMS::DCLsym or die "failed 1\n";
+print "ok 1\n";
+
+tie %syms, VMS::DCLsym or die "failed 2\n";
+print "ok 2\n";
+
+$name = 'FOO_'.time();
+$syms{$name} = 'Perl_test';
+print +($! ? "(\$! = $!) not " : ''),"ok 3\n";
+
+print +($syms{$name} eq 'Perl_test' ? '' : 'not '),"ok 4\n";
+
+($val) = `Show Symbol $name` =~ /(\w+)"$/;
+print +($val eq 'Perl_test' ? '' : 'not '),"ok 5\n";
+
+while (($sym,$val) = each %syms) {
+ last if $sym eq $name && $val eq 'Perl_test';
+}
+print +($sym ? '' : 'not '),"ok 6\n";
+
+delete $syms{$name};
+print +($! ? "(\$! = $!) not " : ''),"ok 7\n";
+
+print +(defined($syms{$name}) ? 'not ' : ''),"ok 8\n";
+undef %syms;
+
+$obj = new VMS::DCLsym 'GLOBAL';
+print +($obj ? '' : 'not '),"ok 9\n";
+
+print +($obj->clearcache(0) ? '' : 'not '),"ok 10\n";
+print +($obj->clearcache(1) ? 'not ' : ''),"ok 11\n";
+
+print +($obj->setsym($name,'Another_test') ? '' : 'not '),"ok 12\n";
+
+($val,$tab) = $obj->getsym($name);
+print +($val eq 'Another_test' && $tab eq 'GLOBAL' ? '' : 'not '),"ok 13\n";
+
+print +($obj->delsym($name,'LOCAL') ? 'not ' : ''),"ok 14\n";
+print +($obj->delsym($name,'GLOBAL') ? '' : 'not '),"ok 15\n";
diff --git a/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm
index af71f0bb9e..ad16af366f 100644
--- a/vms/ext/Stdio/Stdio.pm
+++ b/vms/ext/Stdio/Stdio.pm
@@ -1,8 +1,8 @@
# VMS::Stdio - VMS extensions to Perl's stdio calls
#
# Author: Charles Bailey bailey@genetics.upenn.edu
-# Version: 2.0
-# Revised: 28-Feb-1996
+# Version: 2.01
+# Revised: 10-Dec-1996
package VMS::Stdio;
@@ -12,7 +12,7 @@ use Carp '&croak';
use DynaLoader ();
use Exporter ();
-$VERSION = '2.0';
+$VERSION = '2.01';
@ISA = qw( Exporter DynaLoader IO::File );
@EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT
&O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY );
@@ -32,15 +32,14 @@ sub AUTOLOAD {
if ($constname =~ /^O_/) {
my($val) = constant($constname);
defined $val or croak("Unknown VMS::Stdio constant $constname");
+ *$AUTOLOAD = sub { val; }
}
else { # We don't know about it; hand off to IO::File
require IO::File;
- my($obj) = shift(@_);
- my($val) = eval "\$obj->IO::File::$constname(@_)";
- croak "Error autoloading $constname: $@" if $@;
+ *$AUTOLOAD = eval "sub { shift->IO::File::$constname(\@_) }";
+ croak "Error autoloading IO::File::$constname: $@" if $@;
}
- *$AUTOLOAD = sub { $val };
goto &$AUTOLOAD;
}
@@ -189,9 +188,9 @@ reason, it is unable to generate a name, it returns C<undef>.
=item vmsopen
The C<vmsopen> function enables you to specify optional RMS arguments
-to the VMS CRTL when opening a file. It is similar to the built-in
+to the VMS CRTL when opening a file. Its operation is similar to the built-in
Perl C<open> function (see L<perlfunc> for a complete description),
-but will only open normal files; it cannot open pipes or duplicate
+but it will only open normal files; it cannot open pipes or duplicate
existing I/O handles. Up to 8 optional arguments may follow the
file name. These arguments should be strings which specify
optional file characteristics as allowed by the CRTL. (See the
@@ -199,7 +198,7 @@ CRTL reference manual description of creat() and fopen() for details.)
If successful, C<vmsopen> returns a VMS::Stdio file handle; if an
error occurs, it returns C<undef>.
-You can use the file handle returned by C<vmsfopen> just as you
+You can use the file handle returned by C<vmsopen> just as you
would any other Perl file handle. The class VMS::Stdio ISA
IO::File, so you can call IO::File methods using the handle
returned by C<vmsopen>. However, C<use>ing VMS::Stdio does not
@@ -232,6 +231,6 @@ task by calling the CRTL routine fwait().
=head1 REVISION
-This document was last revised on 28-Jan-1996, for Perl 5.002.
+This document was last revised on 10-Dec-1996, for Perl 5.004.
=cut
diff --git a/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
index a1ec91f500..200268c7f1 100644
--- a/vms/ext/Stdio/Stdio.xs
+++ b/vms/ext/Stdio/Stdio.xs
@@ -100,7 +100,7 @@ newFH(FILE *fp, char type) {
gv_init(gv,stash,"__FH__",6,0);
io = GvIOp(gv) = newIO();
IoIFP(io) = fp;
- if (type != '>') IoOFP(io) = fp;
+ if (type != '<') IoOFP(io) = fp;
IoTYPE(io) = type;
rv = newRV((SV *)gv);
SvREFCNT_dec(gv);
@@ -225,7 +225,7 @@ vmsopen(spec,...)
break;
}
if (fp != Nullfp) {
- SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : '>')));
+ SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
}
else { ST(0) = &sv_undef; }
diff --git a/vms/ext/Stdio/test.pl b/vms/ext/Stdio/test.pl
index 12e508aa1f..0b50d63e3a 100644
--- a/vms/ext/Stdio/test.pl
+++ b/vms/ext/Stdio/test.pl
@@ -1,8 +1,8 @@
-# Tests for VMS::Stdio v2.0
+# Tests for VMS::Stdio v2.01
use VMS::Stdio;
import VMS::Stdio qw(&flush &getname &rewind &sync);
-print "1..13\n";
+print "1..14\n";
print +(defined(&getname) ? '' : 'not '), "ok 1\n";
$name = "test$$";
@@ -16,26 +16,29 @@ print +(sync($fh) ? '' : 'not '),"ok 4\n";
$time = (stat("$name.tmp"))[9];
print +($time ? '' : 'not '), "ok 5\n";
-print 'not ' unless print $fh scalar(localtime($time)),"\n";
+$fh->autoflush; # Can we autoload autoflush from IO::File? Do or die.
print "ok 6\n";
-print +(rewind($fh) ? '' : 'not '),"ok 7\n";
+print 'not ' unless print $fh scalar(localtime($time)),"\n";
+print "ok 7\n";
+
+print +(rewind($fh) ? '' : 'not '),"ok 8\n";
chop($line = <$fh>);
-print +($line eq localtime($time) ? '' : 'not '), "ok 8\n";
+print +($line eq localtime($time) ? '' : 'not '), "ok 9\n";
($gotname) = (getname($fh) =~/\](.*);/);
-print +($gotname eq "\U$name.tmp" ? '' : 'not '), "ok 9\n";
+print +($gotname eq "\U$name.tmp" ? '' : 'not '), "ok 10\n";
$sfh = VMS::Stdio::vmssysopen($name, O_RDONLY, 0,
'ctx=rec', 'shr=put', 'dna=.tmp');
-print +($sfh ? '' : 'not ($!) '), "ok 10\n";
+print +($sfh ? '' : 'not ($!) '), "ok 11\n";
close($fh);
sysread($sfh,$line,24);
-print +($line eq localtime($time) ? '' : 'not '), "ok 11\n";
+print +($line eq localtime($time) ? '' : 'not '), "ok 12\n";
undef $sfh;
-print +(stat("$name.tmp") ? 'not ' : ''),"ok 12\n";
+print +(stat("$name.tmp") ? 'not ' : ''),"ok 13\n";
-print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 13\n";
+print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 14\n";
View Lorry Controller Status