cvs.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxunix.c

   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 }