home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / perl-5.003-src.tgz / tar.out / fsf / perl / vms / ext / Stdio / Stdio.xs < prev    next >
Text File  |  1996-09-28  |  7KB  |  296 lines
  1. /* VMS::Stdio - VMS extensions to stdio routines 
  2.  *
  3.  * Version:  2.0
  4.  * Author:   Charles Bailey  bailey@genetics.upenn.edu
  5.  * Revised:  28-Feb-1996
  6.  *
  7.  */
  8.  
  9. #include "EXTERN.h"
  10. #include "perl.h"
  11. #include "XSUB.h"
  12. #include <file.h>
  13.  
  14. static bool
  15. constant(name, pval)
  16. char *name;
  17. IV *pval;
  18. {
  19.     if (strnNE(name, "O_", 2)) return FALSE;
  20.  
  21.     if (strEQ(name, "O_APPEND"))
  22. #ifdef O_APPEND
  23.     { *pval = O_APPEND; return TRUE; }
  24. #else
  25.     return FALSE;
  26. #endif
  27.     if (strEQ(name, "O_CREAT"))
  28. #ifdef O_CREAT
  29.     { *pval = O_CREAT; return TRUE; }
  30. #else
  31.     return FALSE;
  32. #endif
  33.     if (strEQ(name, "O_EXCL"))
  34. #ifdef O_EXCL
  35.     { *pval = O_EXCL; return TRUE; }
  36. #else
  37.     return FALSE;
  38. #endif
  39.     if (strEQ(name, "O_NDELAY"))
  40. #ifdef O_NDELAY
  41.     { *pval = O_NDELAY; return TRUE; }
  42. #else
  43.     return FALSE;
  44. #endif
  45.     if (strEQ(name, "O_NOWAIT"))
  46. #ifdef O_NOWAIT
  47.     { *pval = O_NOWAIT; return TRUE; }
  48. #else
  49.     return FALSE;
  50. #endif
  51.     if (strEQ(name, "O_RDONLY"))
  52. #ifdef O_RDONLY
  53.     { *pval = O_RDONLY; return TRUE; }
  54. #else
  55.     return FALSE;
  56. #endif
  57.     if (strEQ(name, "O_RDWR"))
  58. #ifdef O_RDWR
  59.     { *pval = O_RDWR; return TRUE; }
  60. #else
  61.     return FALSE;
  62. #endif
  63.     if (strEQ(name, "O_TRUNC"))
  64. #ifdef O_TRUNC
  65.     { *pval = O_TRUNC; return TRUE; }
  66. #else
  67.     return FALSE;
  68. #endif
  69.     if (strEQ(name, "O_WRONLY"))
  70. #ifdef O_WRONLY
  71.     { *pval = O_WRONLY; return TRUE; }
  72. #else
  73.     return FALSE;
  74. #endif
  75.  
  76.     return FALSE;
  77. }
  78.  
  79.  
  80. static SV *
  81. newFH(FILE *fp, char type) {
  82.     SV *rv, *gv = NEWSV(0,0);
  83.     GV **stashp;
  84.     HV *stash;
  85.     IO *io;
  86.  
  87.     /* Find stash for VMS::Stdio.  We don't do this once at boot
  88.      * to allow for possibility of threaded Perl with per-thread
  89.      * symbol tables.  This code (through io = ...) is really
  90.      * equivalent to gv_fetchpv("VMS::Stdio::__FH__",TRUE,SVt_PVIO),
  91.      * with a little less overhead, and good exercise for me. :-) */
  92.     stashp = (GV **)hv_fetch(defstash,"VMS::",5,TRUE);
  93.     if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
  94.     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
  95.     stashp = (GV **)hv_fetch(GvHV(*stashp),"Stdio::",7,TRUE);
  96.     if (!stashp || *stashp == (GV *)&sv_undef) return Nullsv;
  97.     if (!(stash = GvHV(*stashp))) stash = GvHV(*stashp) = newHV();
  98.  
  99.     /* Set up GV to point to IO, and then take reference */
  100.     gv_init(gv,stash,"__FH__",6,0);
  101.     io = GvIOp(gv) = newIO();
  102.     IoIFP(io) = fp;
  103.     if (type != '>') IoOFP(io) = fp;
  104.     IoTYPE(io) = type;
  105.     rv = newRV(gv);
  106.     SvREFCNT_dec(gv);
  107.     return sv_bless(rv,stash);
  108. }
  109.  
  110. MODULE = VMS::Stdio  PACKAGE = VMS::Stdio
  111.  
  112. void
  113. constant(name)
  114.     char *    name
  115.     PROTOTYPE: $
  116.     CODE:
  117.     IV i;
  118.     if (constant(name, &i))
  119.         ST(0) = sv_2mortal(newSViv(i));
  120.     else
  121.         ST(0) = &sv_undef;
  122.  
  123. void
  124. flush(sv)
  125.     SV *    sv
  126.     PROTOTYPE: $
  127.     CODE:
  128.         FILE *fp = Nullfp;
  129.         if (SvOK(sv)) fp = IoIFP(sv_2io(sv));
  130.         ST(0) = fflush(fp) ? &sv_undef : &sv_yes;
  131.  
  132. char *
  133. getname(fp)
  134.     FILE *    fp
  135.     PROTOTYPE: $
  136.     CODE:
  137.         char fname[257];
  138.         ST(0) = sv_newmortal();
  139.         if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
  140.  
  141. void
  142. rewind(fp)
  143.     FILE *    fp
  144.     PROTOTYPE: $
  145.     CODE:
  146.         ST(0) = rewind(fp) ? &sv_undef : &sv_yes;
  147.  
  148. void
  149. remove(name)
  150.     char *name
  151.     PROTOTYPE: $
  152.     CODE:
  153.         ST(0) = remove(name) ? &sv_undef : &sv_yes;
  154.  
  155. void
  156. sync(fp)
  157.     FILE *    fp
  158.     PROTOTYPE: $
  159.     CODE:
  160.         ST(0) = fsync(fileno(fp)) ? &sv_undef : &sv_yes;
  161.  
  162. char *
  163. tmpnam()
  164.     PROTOTYPE:
  165.     CODE:
  166.         char fname[L_tmpnam];
  167.         ST(0) = sv_newmortal();
  168.         if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
  169.  
  170. void
  171. vmsopen(spec,...)
  172.     char *    spec
  173.     PROTOTYPE: @
  174.     CODE:
  175.         char *args[8],mode[3] = {'r','\0','\0'}, type = '<';
  176.         register int i, myargc;
  177.         FILE *fp;
  178.     
  179.         if (!spec || !*spec) {
  180.            SETERRNO(EINVAL,LIB$_INVARG);
  181.            XSRETURN_UNDEF;
  182.         }
  183.         if (items > 9) croak("too many args");
  184.     
  185.         /* First, set up name and mode args from perl's string */
  186.         if (*spec == '+') {
  187.           mode[1] = '+';
  188.           spec++;
  189.         }
  190.         if (*spec == '>') {
  191.           if (*(spec+1) == '>') *mode = 'a', spec += 2;
  192.           else *mode = 'w',  spec++;
  193.         }
  194.         else if (*spec == '<') spec++;
  195.         myargc = items - 1;
  196.         for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),na);
  197.         /* This hack brought to you by C's opaque arglist management */
  198.         switch (myargc) {
  199.           case 0:
  200.             fp = fopen(spec,mode);
  201.             break;
  202.           case 1:
  203.             fp = fopen(spec,mode,args[0]);
  204.             break;
  205.           case 2:
  206.             fp = fopen(spec,mode,args[0],args[1]);
  207.             break;
  208.           case 3:
  209.             fp = fopen(spec,mode,args[0],args[1],args[2]);
  210.             break;
  211.           case 4:
  212.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3]);
  213.             break;
  214.           case 5:
  215.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4]);
  216.             break;
  217.           case 6:
  218.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
  219.             break;
  220.           case 7:
  221.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
  222.             break;
  223.           case 8:
  224.             fp = fopen(spec,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
  225.             break;
  226.         }
  227.         if (fp != Nullfp) {
  228.           SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : '>')));
  229.           ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
  230.         }
  231.         else { ST(0) = &sv_undef; }
  232.  
  233. void
  234. vmssysopen(spec,mode,perm,...)
  235.     char *    spec
  236.     int    mode
  237.     int    perm
  238.     PROTOTYPE: @
  239.     CODE:
  240.         char *args[8];
  241.         int i, myargc, fd;
  242.         FILE *fp;
  243.         SV *fh;
  244.         if (!spec || !*spec) {
  245.            SETERRNO(EINVAL,LIB$_INVARG);
  246.            XSRETURN_UNDEF;
  247.         }
  248.         if (items > 11) croak("too many args");
  249.         myargc = items - 3;
  250.         for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+3),na);
  251.         /* More fun with C calls; can't combine with above because
  252.            args 2,3 of different types in fopen() and open() */
  253.         switch (myargc) {
  254.           case 0:
  255.             fd = open(spec,mode,perm);
  256.             break;
  257.           case 1:
  258.             fd = open(spec,mode,perm,args[0]);
  259.             break;
  260.           case 2:
  261.             fd = open(spec,mode,perm,args[0],args[1]);
  262.             break;
  263.           case 3:
  264.             fd = open(spec,mode,perm,args[0],args[1],args[2]);
  265.             break;
  266.           case 4:
  267.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3]);
  268.             break;
  269.           case 5:
  270.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4]);
  271.             break;
  272.           case 6:
  273.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5]);
  274.             break;
  275.           case 7:
  276.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
  277.             break;
  278.           case 8:
  279.             fd = open(spec,mode,perm,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
  280.             break;
  281.         }
  282.         i = mode & 3;
  283.         if (fd >= 0 &&
  284.            ((fp = fdopen(fd, &("r\000w\000r+"[2*i]))) != Nullfp)) {
  285.           SV *fh = newFH(fp,"<>++"[i]);
  286.           ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
  287.         }
  288.         else { ST(0) = &sv_undef; }
  289.  
  290. void
  291. waitfh(fp)
  292.     FILE *    fp
  293.     PROTOTYPE: $
  294.     CODE:
  295.         ST(0) = fwait(fp) ? &sv_undef : &sv_yes;
  296.