/* * tclXoscmds.c -- * * Tcl commands to access unix system calls that are portable to other * platforms. *----------------------------------------------------------------------------- * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. * * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that the above copyright notice appear in all copies. Karl Lehenbauer and * Mark Diekhans make no representations about the suitability of this * software for any purpose. It is provided "as is" without express or * implied warranty. *----------------------------------------------------------------------------- * $Id: tclXoscmds.c,v 8.11 2001/08/02 00:10:24 hobbs Exp $ *----------------------------------------------------------------------------- */ #include "tclExtdInt.h" static int TclX_AlarmObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TclX_LinkObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TclX_NiceObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TclX_SleepObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TclX_SyncObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TclX_SystemObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TclX_UmaskObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /*----------------------------------------------------------------------------- * TclX_AlarmObjCmd -- * Implements the TCL Alarm command: * alarm seconds * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_AlarmObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { double seconds; if (objc != 2) return TclX_WrongArgs (interp, objv [0], "seconds"); if (Tcl_GetDoubleFromObj (interp, objv[1], &seconds) != TCL_OK) return TCL_ERROR; if (TclXOSsetitimer (interp, &seconds, "alarm") != TCL_OK) return TCL_ERROR; Tcl_SetDoubleObj (Tcl_GetObjResult (interp), seconds); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_LinkObjCmd -- * Implements the TCL link command: * link ?-sym? srcpath destpath * * Results: * Standard TCL results, may return the UNIX system error message. *----------------------------------------------------------------------------- */ static int TclX_LinkObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { char *srcPath, *destPath; Tcl_DString srcPathBuf, destPathBuf; char *argv0String; char *srcPathString; char *destPathString; Tcl_DStringInit (&srcPathBuf); Tcl_DStringInit (&destPathBuf); if ((objc < 3) || (objc > 4)) return TclX_WrongArgs (interp, objv [0], "?-sym? srcpath destpath"); if (objc == 4) { char *argv1String = Tcl_GetStringFromObj (objv [1], NULL); if (!STREQU (argv1String, "-sym")) { TclX_AppendObjResult (interp, "invalid option, expected: \"-sym\", got: ", Tcl_GetStringFromObj (objv [1], NULL), (char *) NULL); return TCL_ERROR; } } srcPathString = Tcl_GetStringFromObj (objv [objc - 2], NULL); srcPath = Tcl_TranslateFileName (interp, srcPathString, &srcPathBuf); if (srcPath == NULL) goto errorExit; destPathString = Tcl_GetStringFromObj (objv [objc - 1], NULL); destPath = Tcl_TranslateFileName (interp, destPathString, &destPathBuf); if (destPath == NULL) goto errorExit; argv0String = Tcl_GetStringFromObj (objv [0], NULL); if (objc == 4) { if (TclX_OSsymlink (interp, srcPath, destPath, argv0String) != TCL_OK) goto errorExit; } else { if (TclX_OSlink (interp, srcPath, destPath, argv0String) != TCL_OK) goto errorExit; } Tcl_DStringFree (&srcPathBuf); Tcl_DStringFree (&destPathBuf); return TCL_OK; errorExit: Tcl_DStringFree (&srcPathBuf); Tcl_DStringFree (&destPathBuf); return TCL_ERROR; } /*----------------------------------------------------------------------------- * TclX_NiceObjCmd -- * Implements the TCL nice command: * nice ?priorityincr? * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_NiceObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *resultPtr = Tcl_GetObjResult (interp); int priorityIncr, priority; char *argv0String; if (objc > 2) return TclX_WrongArgs (interp, objv [0], "?priorityincr?"); argv0String = Tcl_GetStringFromObj (objv [0], NULL); /* * Return the current priority if an increment is not supplied. */ if (objc == 1) { if (TclXOSgetpriority (interp, &priority, argv0String) != TCL_OK) return TCL_ERROR; Tcl_SetIntObj (Tcl_GetObjResult (interp), priority); return TCL_OK; } /* * Increment the priority. */ if (Tcl_GetIntFromObj (interp, objv [1], &priorityIncr) != TCL_OK) return TCL_ERROR; if (TclXOSincrpriority (interp, priorityIncr, &priority, argv0String) != TCL_OK) return TCL_ERROR; Tcl_SetIntObj (resultPtr, priority); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_SleepObjCmd -- * Implements the TCL sleep command: * sleep seconds * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_SleepObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { double time; if (objc != 2) return TclX_WrongArgs (interp, objv [0], "seconds"); if (Tcl_GetDoubleFromObj (interp, objv [1], &time) != TCL_OK) return TCL_ERROR; TclXOSsleep ((int) time); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_SyncObjCmd -- * Implements the TCL sync command: * sync * * Results: * Standard TCL results. * *----------------------------------------------------------------------------- */ static int TclX_SyncObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Channel channel; if ((objc < 1) || (objc > 2)) return TclX_WrongArgs (interp, objv [0], "?filehandle?"); if (objc == 1) { TclXOSsync (); return TCL_OK; } channel = TclX_GetOpenChannelObj (interp, objv [1], TCL_WRITABLE); if (channel == NULL) return TCL_ERROR; if (Tcl_Flush (channel) < 0) { Tcl_SetStringObj (Tcl_GetObjResult (interp), Tcl_PosixError (interp), -1); return TCL_ERROR; } return TclXOSfsync (interp, channel); } /*----------------------------------------------------------------------------- * TclX_SystemObjCmd -- * Implements the TCL system command: * system cmdstr1 ?cmdstr2...? *----------------------------------------------------------------------------- */ static int TclX_SystemObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *cmdObjPtr; char *cmdStr; int exitCode; if (objc < 2) return TclX_WrongArgs (interp, objv [0], "cmdstr1 ?cmdstr2...?"); cmdObjPtr = Tcl_ConcatObj (objc - 1, &(objv[1])); cmdStr = Tcl_GetStringFromObj (cmdObjPtr, NULL); if (TclXOSsystem (interp, cmdStr, &exitCode) != TCL_OK) { Tcl_DecrRefCount (cmdObjPtr); return TCL_ERROR; } Tcl_SetIntObj (Tcl_GetObjResult (interp), exitCode); Tcl_DecrRefCount (cmdObjPtr); return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_UmaskObjCmd -- * Implements the TCL umask command: * umask ?octalmask? * * Results: * Standard TCL results, may return the UNIX system error message. * *----------------------------------------------------------------------------- */ static int TclX_UmaskObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { int mask; char *umaskString; char numBuf [32]; if ((objc < 1) || (objc > 2)) return TclX_WrongArgs (interp, objv [0], "?octalmask?"); /* * FIX: Should include leading 0 to make it a legal number. */ if (objc == 1) { mask = umask (0); umask ((unsigned short) mask); sprintf (numBuf, "%o", mask); Tcl_SetStringObj (Tcl_GetObjResult (interp), numBuf, -1); } else { umaskString = Tcl_GetStringFromObj (objv [1], NULL); if (!TclX_StrToInt (umaskString, 8, &mask)) { TclX_AppendObjResult (interp, "Expected octal number got: ", Tcl_GetStringFromObj (objv [1], NULL), (char *) NULL); return TCL_ERROR; } umask ((unsigned short) mask); } return TCL_OK; } /*----------------------------------------------------------------------------- * TclX_OsCmdsInit -- * Initialize the OS related commands. *----------------------------------------------------------------------------- */ void TclX_OsCmdsInit (Tcl_Interp *interp) { Tcl_CreateObjCommand (interp, "alarm", TclX_AlarmObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "link", TclX_LinkObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); Tcl_CreateObjCommand (interp, "nice", TclX_NiceObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); TclX_CreateObjCommand (interp, "sleep", TclX_SleepObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL, 0); Tcl_CreateObjCommand (interp, "sync", TclX_SyncObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); TclX_CreateObjCommand (interp, "system", TclX_SystemObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL, 0); Tcl_CreateObjCommand (interp, "umask", TclX_UmaskObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); } /* vim: set ts=4 sw=4 sts=4 et : */