]>
cvs.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxunix.c
4 * Tcl commands to access unix library calls.
5 *-----------------------------------------------------------------------------
6 * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
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
14 *-----------------------------------------------------------------------------
15 * $Id: tclXunixcmds.c,v 2.0 1992/10/16 04:51:18 markd Rel $
16 *-----------------------------------------------------------------------------
22 * A million microsecondss per seconds.
24 #define TCL_USECS_PER_SEC (1000L * 1000L)
33 *-----------------------------------------------------------------------------
36 * Implements the TCL Alarm command:
40 * Standard TCL results, may return the UNIX system error message.
42 *-----------------------------------------------------------------------------
45 Tcl_AlarmCmd (clientData
, interp
, argc
, argv
)
46 ClientData clientData
;
56 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0], " seconds",
61 if (Tcl_GetDouble (interp
, argv
[1], &seconds
) != TCL_OK
)
64 useconds
= ceil (seconds
);
66 sprintf (interp
->result
, "%d", sleep (useconds
));
68 sprintf (interp
->result
, "%d", alarm (useconds
));
74 double seconds
, secFloor
;
75 struct itimerval timer
, oldTimer
;
78 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0], " seconds",
83 if (Tcl_GetDouble (interp
, argv
[1], &seconds
) != TCL_OK
)
86 secFloor
= floor (seconds
);
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;
95 if (setitimer (ITIMER_REAL
, &timer
, &oldTimer
) < 0) {
96 interp
->result
= Tcl_UnixError (interp
);
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
);
110 *-----------------------------------------------------------------------------
113 * Implements the TCL sleep command:
117 * Standard TCL results, may return the UNIX system error message.
119 *-----------------------------------------------------------------------------
122 Tcl_SleepCmd (clientData
, interp
, argc
, argv
)
123 ClientData clientData
;
131 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0], " seconds",
136 if (Tcl_GetUnsigned (interp
, argv
[1], &time
) != TCL_OK
)
145 *-----------------------------------------------------------------------------
148 * Implements the TCL system command:
152 * Standard TCL results, may return the UNIX system error message.
154 *-----------------------------------------------------------------------------
157 Tcl_SystemCmd (clientData
, interp
, argc
, argv
)
158 ClientData clientData
;
166 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0], " command",
171 exitCode
= Tcl_System (interp
, argv
[1]);
174 sprintf (interp
->result
, "%d", exitCode
);
179 *-----------------------------------------------------------------------------
182 * Implements the TCL times command:
186 * Standard TCL results.
188 *-----------------------------------------------------------------------------
191 Tcl_TimesCmd (clientData
, interp
, argc
, argv
)
192 ClientData clientData
;
200 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0], (char *) NULL
);
206 sprintf(interp
->result
, "%ld %ld %ld %ld",
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
);
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
);
222 *-----------------------------------------------------------------------------
225 * Implements the TCL umask command:
229 * Standard TCL results, may return the UNIX system error message.
231 *-----------------------------------------------------------------------------
234 Tcl_UmaskCmd (clientData
, interp
, argc
, argv
)
235 ClientData clientData
;
242 if ((argc
< 1) || (argc
> 2)) {
243 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0], " octalmask",
250 umask ((unsigned short) mask
);
251 sprintf (interp
->result
, "%o", mask
);
253 if (!Tcl_StrToInt (argv
[1], 8, &mask
)) {
254 Tcl_AppendResult (interp
, "Expected octal number got: ", argv
[1],
259 umask ((unsigned short) mask
);
266 *-----------------------------------------------------------------------------
269 * Implements the TCL link command:
270 * link [-sym] srcpath destpath
273 * Standard TCL results, may return the UNIX system error message.
275 *-----------------------------------------------------------------------------
278 Tcl_LinkCmd (clientData
, interp
, argc
, argv
)
279 ClientData clientData
;
284 char *tmppath
, *srcpath
, *destpath
;
286 if ((argc
< 3) || (argc
> 4)) {
287 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
288 " [-sym] srcpath destpath", (char *) NULL
);
292 if (!STREQU (argv
[1], "-sym")) {
293 Tcl_AppendResult (interp
, "invalid option, expected: \"-sym\", ",
294 "got: ", argv
[1], (char *) NULL
);
298 Tcl_AppendResult (interp
, "symbolic links are not supported on this",
299 " system", (char *) NULL
);
304 tmppath
= Tcl_TildeSubst (interp
, argv
[argc
- 2]);
307 srcpath
= ckalloc (strlen (tmppath
) + 1);
308 strcpy (srcpath
, tmppath
);
310 destpath
= Tcl_TildeSubst (interp
, argv
[argc
- 1]);
311 if (destpath
== NULL
)
316 if (symlink (srcpath
, destpath
) != 0)
320 if (link (srcpath
, destpath
) != 0)
327 interp
->result
= Tcl_UnixError (interp
);
335 *-----------------------------------------------------------------------------
338 * Implements the TCL unlink command:
339 * unlink [-nocomplain] fileList
342 * Standard TCL results, may return the UNIX system error message.
344 *-----------------------------------------------------------------------------
347 Tcl_UnlinkCmd (clientData
, interp
, argc
, argv
)
348 ClientData clientData
;
354 char **fileArgv
, *fileName
;
357 if ((argc
< 2) || (argc
> 3))
361 if (!STREQU (argv
[1], "-nocomplain"))
368 if (Tcl_SplitList (interp
, argv
[argc
- 1], &fileArgc
,
369 &fileArgv
) != TCL_OK
)
372 for (idx
= 0; idx
< fileArgc
; idx
++) {
373 fileName
= Tcl_TildeSubst (interp
, fileArgv
[idx
]);
374 if (fileName
== NULL
) {
379 if ((unlink (fileName
) != 0) && !noComplain
) {
380 Tcl_AppendResult (interp
, fileArgv
[idx
], ": ",
381 Tcl_UnixError (interp
), (char *) NULL
);
386 ckfree ((char *) fileArgv
);
390 ckfree ((char *) fileArgv
);
394 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
395 " [-nocomplain] filelist", (char *) NULL
);
400 *-----------------------------------------------------------------------------
403 * Implements the TCL Mkdir command:
404 * mkdir [-path] dirList
407 * Standard TCL results, may return the UNIX system error message.
409 *-----------------------------------------------------------------------------
412 Tcl_MkdirCmd (clientData
, interp
, argc
, argv
)
413 ClientData clientData
;
418 int idx
, dirArgc
, result
;
419 char **dirArgv
, *scanPtr
;
422 if ((argc
< 2) || (argc
> 3))
424 if ((argc
== 3) && !STREQU (argv
[1], "-path"))
427 if (Tcl_SplitList (interp
, argv
[argc
- 1], &dirArgc
, &dirArgv
) != TCL_OK
)
430 * Make all the directories, optionally making directories along the path.
433 for (idx
= 0; idx
< dirArgc
; idx
++) {
435 * Make leading directories, if requested.
438 scanPtr
= dirArgv
[idx
];
439 result
= 0; /* Start out ok, for dirs that are skipped */
441 while (*scanPtr
!= '\0') {
442 scanPtr
= strchr (scanPtr
+1, '/');
443 if ((scanPtr
== NULL
) || (*(scanPtr
+1) == '\0'))
446 if (stat (dirArgv
[idx
], &statBuf
) < 0)
447 result
= mkdir (dirArgv
[idx
], S_IFDIR
| 0777);
454 * Make final directory in the path.
456 if (mkdir (dirArgv
[idx
], S_IFDIR
| 0777) != 0)
460 ckfree ((char *) dirArgv
);
464 Tcl_AppendResult (interp
, dirArgv
[idx
], ": ", Tcl_UnixError (interp
),
466 ckfree ((char *) dirArgv
);
470 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
471 " [-path] dirlist", (char *) NULL
);
476 *-----------------------------------------------------------------------------
479 * Implements the TCL Rmdir command:
480 * rmdir [-nocomplain] dirList
483 * Standard TCL results, may return the UNIX system error message.
485 *-----------------------------------------------------------------------------
488 Tcl_RmdirCmd (clientData
, interp
, argc
, argv
)
489 ClientData clientData
;
495 char **dirArgv
, *dirName
;
498 if ((argc
< 2) || (argc
> 3))
502 if (!STREQU (argv
[1], "-nocomplain"))
509 if (Tcl_SplitList (interp
, argv
[argc
- 1], &dirArgc
, &dirArgv
) != TCL_OK
)
512 for (idx
= 0; idx
< dirArgc
; idx
++) {
513 dirName
= Tcl_TildeSubst (interp
, dirArgv
[idx
]);
514 if (dirName
== NULL
) {
519 if ((rmdir (dirName
) != 0) && !noComplain
) {
520 Tcl_AppendResult (interp
, dirArgv
[idx
], ": ",
521 Tcl_UnixError (interp
), (char *) NULL
);
526 ckfree ((char *) dirArgv
);
530 ckfree ((char *) dirArgv
);
534 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
535 " [-nocomplain] dirlist", (char *) NULL
);