diff options
author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1996-12-19 16:44:00 +1200 |
---|---|---|
committer | Chip Salzenberg <chip@atlantic.net> | 1996-12-19 16:44:00 +1200 |
commit | 5f05dabc4054964aa3b10f44f8468547f051cdf8 (patch) | |
tree | 7bcc2c7b6d5cf44e7f0111bac2240ca979d9c804 /vms/ext | |
parent | 6a3992aa749356d657a4c0e14be8c2f4c2f4f999 (diff) | |
download | perl-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.txt | 21 | ||||
-rw-r--r-- | vms/ext/DCLsym/DCLsym.pm | 268 | ||||
-rw-r--r-- | vms/ext/DCLsym/DCLsym.xs | 151 | ||||
-rw-r--r-- | vms/ext/DCLsym/Makefile.PL | 3 | ||||
-rw-r--r-- | vms/ext/DCLsym/test.pl | 41 | ||||
-rw-r--r-- | vms/ext/Stdio/Stdio.pm | 21 | ||||
-rw-r--r-- | vms/ext/Stdio/Stdio.xs | 4 | ||||
-rw-r--r-- | vms/ext/Stdio/test.pl | 23 |
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"; |