[perl #9328] Update INSTALL example for BerkeleyDB install
[perl.git] / epoc / epoc.c
1 /*
2  *    Copyright (c) 1999 Olaf Flebbe o.flebbe@gmx.de
3  *    
4  *    You may distribute under the terms of either the GNU General Public
5  *    License or the Artistic License, as specified in the README file.
6  *
7  */
8
9 #include <stdlib.h>
10 #include <string.h>
11 #include <stdio.h>
12 #include <sys/unistd.h>
13 #include <process.h>
14
15
16 #include "EXTERN.h"
17 #include "perl.h"
18 #include "XSUB.h"
19
20 int 
21 do_spawn( char *cmd) {
22     dTHX;
23     return system( cmd);
24 }
25
26 int
27 do_aspawn ( void *vreally, void **vmark, void **vsp) {
28
29     dTHX;
30
31     SV *really = (SV*)vreally;
32     SV **mark = (SV**)vmark;
33     SV **sp = (SV**)vsp;
34
35     char **argv;
36     char *str;
37     char *p2, **ptr;
38     char *cmd;
39
40
41     int  rc;
42     int index = 0;
43
44     if (sp<=mark)
45       return -1;
46     
47     ptr = argv =(char**) malloc ((sp-mark+3)*sizeof (char*));
48     
49     while (++mark <= sp) {
50       if (*mark && (str = SvPV_nolen(*mark)))
51         argv[index] = str;
52       else
53         argv[index] = "";
54     }
55     argv[index++] = 0;
56
57     cmd = strdup((const char*)(really ? SvPV_nolen(really) : argv[0]));
58
59     rc = spawnvp( P_WAIT, cmd, argv);
60     free( argv);
61     free( cmd);
62
63     return rc;
64 }
65
66 static
67 XS(epoc_getcwd)   /* more or less stolen from win32.c */
68 {
69     dXSARGS;
70     /* Make the host for current directory */
71     char *buffer; 
72     int buflen = 256;
73
74     char *ptr;
75     buffer = (char *) malloc( buflen);
76     if (buffer == NULL) {
77       XSRETURN_UNDEF;
78     }
79     while ((NULL == ( ptr = getcwd( buffer, buflen))) && (errno == ERANGE)) {
80       buflen *= 2;
81       if (NULL == realloc( buffer, buflen)) {
82          XSRETURN_UNDEF;
83       }
84       
85     }
86
87     /* 
88      * If ptr != NULL 
89      *   then it worked, set PV valid, 
90      *   else return 'undef' 
91      */
92
93     if (ptr) {
94         SV *sv = sv_newmortal();
95         char *tptr;
96
97         for (tptr = ptr; *tptr != '\0'; tptr++) {
98           if (*tptr == '\\') {
99             *tptr = '/';
100           }
101         }
102         sv_setpv(sv, ptr);
103         free( buffer);
104
105         EXTEND(SP,1);
106         SvPOK_on(sv);
107         ST(0) = sv;
108 #ifndef INCOMPLETE_TAINTS
109         SvTAINTED_on(ST(0));
110 #endif
111         XSRETURN(1);
112     }
113     free( buffer);
114     XSRETURN_UNDEF;
115 }
116   
117
118 void
119 Perl_init_os_extras(void)
120
121   dTHX;
122   char *file = __FILE__;
123   newXS("EPOC::getcwd", epoc_getcwd, file);
124 }
125