]>
Commit | Line | Data |
---|---|---|
1 | /* | |
2 | * tclXunixcmds.c -- | |
3 | * | |
4 | * Tcl commands to access unix library calls. | |
5 | *----------------------------------------------------------------------------- | |
6 | * Copyright 1992 Karl Lehenbauer and Mark Diekhans. | |
7 | * | |
8 | * Permission to use, copy, modify, and distribute this software and its | |
9 | * documentation for any purpose and without fee is hereby granted, provided | |
10 | * that the above copyright notice appear in all copies. Karl Lehenbauer and | |
11 | * Mark Diekhans make no representations about the suitability of this | |
12 | * software for any purpose. It is provided "as is" without express or | |
13 | * implied warranty. | |
14 | *----------------------------------------------------------------------------- | |
15 | * $Id: tclXunixcmds.c,v 2.0 1992/10/16 04:51:18 markd Rel $ | |
16 | *----------------------------------------------------------------------------- | |
17 | */ | |
18 | ||
19 | #include "tclxint.h" | |
20 | ||
21 | /* | |
22 | * A million microsecondss per seconds. | |
23 | */ | |
24 | #define TCL_USECS_PER_SEC (1000L * 1000L) | |
25 | ||
26 | extern | |
27 | double floor (); | |
28 | ||
29 | extern | |
30 | double ceil (); | |
31 | \f | |
32 | /* | |
33 | *----------------------------------------------------------------------------- | |
34 | * | |
35 | * Tcl_AlarmCmd -- | |
36 | * Implements the TCL Alarm command: | |
37 | * alarm seconds | |
38 | * | |
39 | * Results: | |
40 | * Standard TCL results, may return the UNIX system error message. | |
41 | * | |
42 | *----------------------------------------------------------------------------- | |
43 | */ | |
44 | int | |
45 | Tcl_AlarmCmd (clientData, interp, argc, argv) | |
46 | ClientData clientData; | |
47 | Tcl_Interp *interp; | |
48 | int argc; | |
49 | char **argv; | |
50 | { | |
51 | #ifdef TCL_NO_ITIMER | |
52 | double seconds; | |
53 | unsigned useconds; | |
54 | ||
55 | if (argc != 2) { | |
56 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " seconds", | |
57 | (char *) NULL); | |
58 | return TCL_ERROR; | |
59 | } | |
60 | ||
61 | if (Tcl_GetDouble (interp, argv[1], &seconds) != TCL_OK) | |
62 | return TCL_ERROR; | |
63 | ||
64 | useconds = ceil (seconds); | |
65 | #ifdef MSDOS | |
66 | sprintf (interp->result, "%d", sleep (useconds)); | |
67 | #else | |
68 | sprintf (interp->result, "%d", alarm (useconds)); | |
69 | #endif | |
70 | ||
71 | return TCL_OK; | |
72 | #else | |
73 | ||
74 | double seconds, secFloor; | |
75 | struct itimerval timer, oldTimer; | |
76 | ||
77 | if (argc != 2) { | |
78 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " seconds", | |
79 | (char *) NULL); | |
80 | return TCL_ERROR; | |
81 | } | |
82 | ||
83 | if (Tcl_GetDouble (interp, argv[1], &seconds) != TCL_OK) | |
84 | return TCL_ERROR; | |
85 | ||
86 | secFloor = floor (seconds); | |
87 | ||
88 | timer.it_value.tv_sec = secFloor; | |
89 | timer.it_value.tv_usec = (long) ((seconds - secFloor) * | |
90 | (double) TCL_USECS_PER_SEC); | |
91 | timer.it_interval.tv_sec = 0; | |
92 | timer.it_interval.tv_usec = 0; | |
93 | ||
94 | ||
95 | if (setitimer (ITIMER_REAL, &timer, &oldTimer) < 0) { | |
96 | interp->result = Tcl_UnixError (interp); | |
97 | return TCL_ERROR; | |
98 | } | |
99 | seconds = oldTimer.it_value.tv_sec; | |
100 | seconds += ((double) oldTimer.it_value.tv_usec) / | |
101 | ((double) TCL_USECS_PER_SEC); | |
102 | sprintf (interp->result, "%g", seconds); | |
103 | ||
104 | return TCL_OK; | |
105 | #endif | |
106 | ||
107 | } | |
108 | \f | |
109 | /* | |
110 | *----------------------------------------------------------------------------- | |
111 | * | |
112 | * Tcl_SleepCmd -- | |
113 | * Implements the TCL sleep command: | |
114 | * sleep seconds | |
115 | * | |
116 | * Results: | |
117 | * Standard TCL results, may return the UNIX system error message. | |
118 | * | |
119 | *----------------------------------------------------------------------------- | |
120 | */ | |
121 | int | |
122 | Tcl_SleepCmd (clientData, interp, argc, argv) | |
123 | ClientData clientData; | |
124 | Tcl_Interp *interp; | |
125 | int argc; | |
126 | char **argv; | |
127 | { | |
128 | unsigned time; | |
129 | ||
130 | if (argc != 2) { | |
131 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " seconds", | |
132 | (char *) NULL); | |
133 | return TCL_ERROR; | |
134 | } | |
135 | ||
136 | if (Tcl_GetUnsigned (interp, argv[1], &time) != TCL_OK) | |
137 | return TCL_ERROR; | |
138 | ||
139 | sleep (time); | |
140 | return TCL_OK; | |
141 | ||
142 | } | |
143 | \f | |
144 | /* | |
145 | *----------------------------------------------------------------------------- | |
146 | * | |
147 | * Tcl_SystemCmd -- | |
148 | * Implements the TCL system command: | |
149 | * system command | |
150 | * | |
151 | * Results: | |
152 | * Standard TCL results, may return the UNIX system error message. | |
153 | * | |
154 | *----------------------------------------------------------------------------- | |
155 | */ | |
156 | int | |
157 | Tcl_SystemCmd (clientData, interp, argc, argv) | |
158 | ClientData clientData; | |
159 | Tcl_Interp *interp; | |
160 | int argc; | |
161 | char **argv; | |
162 | { | |
163 | int exitCode; | |
164 | ||
165 | if (argc != 2) { | |
166 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " command", | |
167 | (char *) NULL); | |
168 | return TCL_ERROR; | |
169 | } | |
170 | ||
171 | exitCode = Tcl_System (interp, argv[1]); | |
172 | if (exitCode == -1) | |
173 | return TCL_ERROR; | |
174 | sprintf (interp->result, "%d", exitCode); | |
175 | return TCL_OK; | |
176 | } | |
177 | \f | |
178 | /* | |
179 | *----------------------------------------------------------------------------- | |
180 | * | |
181 | * Tcl_TimesCmd -- | |
182 | * Implements the TCL times command: | |
183 | * times | |
184 | * | |
185 | * Results: | |
186 | * Standard TCL results. | |
187 | * | |
188 | *----------------------------------------------------------------------------- | |
189 | */ | |
190 | int | |
191 | Tcl_TimesCmd (clientData, interp, argc, argv) | |
192 | ClientData clientData; | |
193 | Tcl_Interp *interp; | |
194 | int argc; | |
195 | char **argv; | |
196 | { | |
197 | struct tms tm; | |
198 | ||
199 | if (argc != 1) { | |
200 | Tcl_AppendResult (interp, tclXWrongArgs, argv[0], (char *) NULL); | |
201 | return TCL_ERROR; | |
202 | } | |
203 | ||
204 | times(&tm); | |
205 | ||
206 | sprintf(interp->result, "%ld %ld %ld %ld", | |
207 | #ifdef MSDOS | |
208 | tm.tms_utime * MS_PER_TICK, | |
209 | tm.tms_utime2 * MS_PER_TICK, | |
210 | tm.tms_stime * MS_PER_TICK, | |
211 | tm.tms_stime2 * MS_PER_TICK); | |
212 | #else | |
213 | tm.tms_utime * MS_PER_TICK, | |
214 | tm.tms_stime * MS_PER_TICK, | |
215 | tm.tms_cutime * MS_PER_TICK, | |
216 | tm.tms_cstime * MS_PER_TICK); | |
217 | #endif | |
218 | return TCL_OK; | |
219 | } | |
220 | \f | |
221 | /* | |
222 | *----------------------------------------------------------------------------- | |
223 | * | |
224 | * Tcl_UmaskCmd -- | |
225 | * Implements the TCL umask command: | |
226 | * umask [octalmask] | |
227 | * | |
228 | * Results: | |
229 | * Standard TCL results, may return the UNIX system error message. | |
230 | * | |
231 | *----------------------------------------------------------------------------- | |
232 | */ | |
233 | int | |
234 | Tcl_UmaskCmd (clientData, interp, argc, argv) | |
235 | ClientData clientData; | |
236 | Tcl_Interp *interp; | |
237 | int argc; | |
238 | char **argv; | |
239 | { | |
240 | int mask; | |
241 | ||
242 | if ((argc < 1) || (argc > 2)) { | |
243 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " octalmask", | |
244 | (char *) NULL); | |
245 | return TCL_ERROR; | |
246 | } | |
247 | ||
248 | if (argc == 1) { | |
249 | mask = umask (0); | |
250 | umask ((unsigned short) mask); | |
251 | sprintf (interp->result, "%o", mask); | |
252 | } else { | |
253 | if (!Tcl_StrToInt (argv [1], 8, &mask)) { | |
254 | Tcl_AppendResult (interp, "Expected octal number got: ", argv [1], | |
255 | (char *) NULL); | |
256 | return TCL_ERROR; | |
257 | } | |
258 | ||
259 | umask ((unsigned short) mask); | |
260 | } | |
261 | ||
262 | return TCL_OK; | |
263 | } | |
264 | \f | |
265 | /* | |
266 | *----------------------------------------------------------------------------- | |
267 | * | |
268 | * Tcl_LinkCmd -- | |
269 | * Implements the TCL link command: | |
270 | * link [-sym] srcpath destpath | |
271 | * | |
272 | * Results: | |
273 | * Standard TCL results, may return the UNIX system error message. | |
274 | * | |
275 | *----------------------------------------------------------------------------- | |
276 | */ | |
277 | int | |
278 | Tcl_LinkCmd (clientData, interp, argc, argv) | |
279 | ClientData clientData; | |
280 | Tcl_Interp *interp; | |
281 | int argc; | |
282 | char **argv; | |
283 | { | |
284 | char *tmppath, *srcpath, *destpath; | |
285 | ||
286 | if ((argc < 3) || (argc > 4)) { | |
287 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], | |
288 | " [-sym] srcpath destpath", (char *) NULL); | |
289 | return TCL_ERROR; | |
290 | } | |
291 | if (argc == 4) { | |
292 | if (!STREQU (argv [1], "-sym")) { | |
293 | Tcl_AppendResult (interp, "invalid option, expected: \"-sym\", ", | |
294 | "got: ", argv [1], (char *) NULL); | |
295 | return TCL_ERROR; | |
296 | } | |
297 | #ifndef S_IFLNK | |
298 | Tcl_AppendResult (interp, "symbolic links are not supported on this", | |
299 | " system", (char *) NULL); | |
300 | return TCL_ERROR; | |
301 | #endif | |
302 | } | |
303 | ||
304 | tmppath = Tcl_TildeSubst (interp, argv [argc - 2]); | |
305 | if (tmppath == NULL) | |
306 | return TCL_ERROR; | |
307 | srcpath = ckalloc (strlen (tmppath) + 1); | |
308 | strcpy (srcpath, tmppath); | |
309 | ||
310 | destpath = Tcl_TildeSubst (interp, argv [argc - 1]); | |
311 | if (destpath == NULL) | |
312 | goto errorExit; | |
313 | ||
314 | if (argc == 4) { | |
315 | #ifdef S_IFLNK | |
316 | if (symlink (srcpath, destpath) != 0) | |
317 | goto unixError; | |
318 | #endif | |
319 | } else { | |
320 | if (link (srcpath, destpath) != 0) | |
321 | goto unixError; | |
322 | } | |
323 | ckfree (srcpath); | |
324 | return TCL_OK; | |
325 | ||
326 | unixError: | |
327 | interp->result = Tcl_UnixError (interp); | |
328 | ||
329 | errorExit: | |
330 | ckfree (srcpath); | |
331 | return TCL_ERROR; | |
332 | } | |
333 | \f | |
334 | /* | |
335 | *----------------------------------------------------------------------------- | |
336 | * | |
337 | * Tcl_UnlinkCmd -- | |
338 | * Implements the TCL unlink command: | |
339 | * unlink [-nocomplain] fileList | |
340 | * | |
341 | * Results: | |
342 | * Standard TCL results, may return the UNIX system error message. | |
343 | * | |
344 | *----------------------------------------------------------------------------- | |
345 | */ | |
346 | int | |
347 | Tcl_UnlinkCmd (clientData, interp, argc, argv) | |
348 | ClientData clientData; | |
349 | Tcl_Interp *interp; | |
350 | int argc; | |
351 | char **argv; | |
352 | { | |
353 | int idx, fileArgc; | |
354 | char **fileArgv, *fileName; | |
355 | int noComplain; | |
356 | ||
357 | if ((argc < 2) || (argc > 3)) | |
358 | goto badArgs; | |
359 | ||
360 | if (argc == 3) { | |
361 | if (!STREQU (argv [1], "-nocomplain")) | |
362 | goto badArgs; | |
363 | noComplain = TRUE; | |
364 | } else { | |
365 | noComplain = FALSE; | |
366 | } | |
367 | ||
368 | if (Tcl_SplitList (interp, argv [argc - 1], &fileArgc, | |
369 | &fileArgv) != TCL_OK) | |
370 | return TCL_ERROR; | |
371 | ||
372 | for (idx = 0; idx < fileArgc; idx++) { | |
373 | fileName = Tcl_TildeSubst (interp, fileArgv [idx]); | |
374 | if (fileName == NULL) { | |
375 | if (!noComplain) | |
376 | goto errorExit; | |
377 | continue; | |
378 | } | |
379 | if ((unlink (fileName) != 0) && !noComplain) { | |
380 | Tcl_AppendResult (interp, fileArgv [idx], ": ", | |
381 | Tcl_UnixError (interp), (char *) NULL); | |
382 | goto errorExit; | |
383 | } | |
384 | } | |
385 | ||
386 | ckfree ((char *) fileArgv); | |
387 | return TCL_OK; | |
388 | ||
389 | errorExit: | |
390 | ckfree ((char *) fileArgv); | |
391 | return TCL_ERROR; | |
392 | ||
393 | badArgs: | |
394 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], | |
395 | " [-nocomplain] filelist", (char *) NULL); | |
396 | return TCL_ERROR; | |
397 | } | |
398 | \f | |
399 | /* | |
400 | *----------------------------------------------------------------------------- | |
401 | * | |
402 | * Tcl_MkdirCmd -- | |
403 | * Implements the TCL Mkdir command: | |
404 | * mkdir [-path] dirList | |
405 | * | |
406 | * Results: | |
407 | * Standard TCL results, may return the UNIX system error message. | |
408 | * | |
409 | *----------------------------------------------------------------------------- | |
410 | */ | |
411 | int | |
412 | Tcl_MkdirCmd (clientData, interp, argc, argv) | |
413 | ClientData clientData; | |
414 | Tcl_Interp *interp; | |
415 | int argc; | |
416 | char **argv; | |
417 | { | |
418 | int idx, dirArgc, result; | |
419 | char **dirArgv, *scanPtr; | |
420 | struct stat statBuf; | |
421 | ||
422 | if ((argc < 2) || (argc > 3)) | |
423 | goto usageError; | |
424 | if ((argc == 3) && !STREQU (argv [1], "-path")) | |
425 | goto usageError; | |
426 | ||
427 | if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK) | |
428 | return TCL_ERROR; | |
429 | /* | |
430 | * Make all the directories, optionally making directories along the path. | |
431 | */ | |
432 | ||
433 | for (idx = 0; idx < dirArgc; idx++) { | |
434 | /* | |
435 | * Make leading directories, if requested. | |
436 | */ | |
437 | if (argc == 3) { | |
438 | scanPtr = dirArgv [idx]; | |
439 | result = 0; /* Start out ok, for dirs that are skipped */ | |
440 | ||
441 | while (*scanPtr != '\0') { | |
442 | scanPtr = strchr (scanPtr+1, '/'); | |
443 | if ((scanPtr == NULL) || (*(scanPtr+1) == '\0')) | |
444 | break; | |
445 | *scanPtr = '\0'; | |
446 | if (stat (dirArgv [idx], &statBuf) < 0) | |
447 | result = mkdir (dirArgv [idx], S_IFDIR | 0777); | |
448 | *scanPtr = '/'; | |
449 | if (result < 0) | |
450 | goto mkdirError; | |
451 | } | |
452 | } | |
453 | /* | |
454 | * Make final directory in the path. | |
455 | */ | |
456 | if (mkdir (dirArgv [idx], S_IFDIR | 0777) != 0) | |
457 | goto mkdirError; | |
458 | } | |
459 | ||
460 | ckfree ((char *) dirArgv); | |
461 | return TCL_OK; | |
462 | ||
463 | mkdirError: | |
464 | Tcl_AppendResult (interp, dirArgv [idx], ": ", Tcl_UnixError (interp), | |
465 | (char *) NULL); | |
466 | ckfree ((char *) dirArgv); | |
467 | return TCL_ERROR; | |
468 | ||
469 | usageError: | |
470 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], | |
471 | " [-path] dirlist", (char *) NULL); | |
472 | return TCL_ERROR; | |
473 | } | |
474 | \f | |
475 | /* | |
476 | *----------------------------------------------------------------------------- | |
477 | * | |
478 | * Tcl_RmdirCmd -- | |
479 | * Implements the TCL Rmdir command: | |
480 | * rmdir [-nocomplain] dirList | |
481 | * | |
482 | * Results: | |
483 | * Standard TCL results, may return the UNIX system error message. | |
484 | * | |
485 | *----------------------------------------------------------------------------- | |
486 | */ | |
487 | int | |
488 | Tcl_RmdirCmd (clientData, interp, argc, argv) | |
489 | ClientData clientData; | |
490 | Tcl_Interp *interp; | |
491 | int argc; | |
492 | char **argv; | |
493 | { | |
494 | int idx, dirArgc; | |
495 | char **dirArgv, *dirName; | |
496 | int noComplain; | |
497 | ||
498 | if ((argc < 2) || (argc > 3)) | |
499 | goto badArgs; | |
500 | ||
501 | if (argc == 3) { | |
502 | if (!STREQU (argv [1], "-nocomplain")) | |
503 | goto badArgs; | |
504 | noComplain = TRUE; | |
505 | } else { | |
506 | noComplain = FALSE; | |
507 | } | |
508 | ||
509 | if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK) | |
510 | return TCL_ERROR; | |
511 | ||
512 | for (idx = 0; idx < dirArgc; idx++) { | |
513 | dirName = Tcl_TildeSubst (interp, dirArgv [idx]); | |
514 | if (dirName == NULL) { | |
515 | if (!noComplain) | |
516 | goto errorExit; | |
517 | continue; | |
518 | } | |
519 | if ((rmdir (dirName) != 0) && !noComplain) { | |
520 | Tcl_AppendResult (interp, dirArgv [idx], ": ", | |
521 | Tcl_UnixError (interp), (char *) NULL); | |
522 | goto errorExit; | |
523 | } | |
524 | } | |
525 | ||
526 | ckfree ((char *) dirArgv); | |
527 | return TCL_OK; | |
528 | ||
529 | errorExit: | |
530 | ckfree ((char *) dirArgv); | |
531 | return TCL_ERROR;; | |
532 | ||
533 | badArgs: | |
534 | Tcl_AppendResult (interp, tclXWrongArgs, argv [0], | |
535 | " [-nocomplain] dirlist", (char *) NULL); | |
536 | return TCL_ERROR; | |
537 | } |