CMcC: This is a critcl rendering of some TclX functions useful under Unix.
package provide userid 1.0
critcl::ccode {
#include <pwd.h>
#include <grp.h>
#include <unistd.h>
#include <sys/types.h>
#include <time.h>
#include <tcl.h>
static int confNGroups = -1;
static int UsernameToUseridResult (Tcl_Interp *interp, char *userName)
{
struct passwd *pw = getpwnam (userName);
Tcl_Obj *resultObj = Tcl_GetObjResult (interp);
if (pw == NULL) {
Tcl_AppendStringsToObj (resultObj,
"unknown user id: ",
userName,
(char *) NULL);
endpwent ();
return TCL_ERROR;
}
Tcl_SetObjResult (interp, Tcl_NewIntObj (pw->pw_uid));
endpwent ();
return TCL_OK;
}
static int UseridToUsernameResult (Tcl_Interp *interp, int userId)
{
uid_t uid = (uid_t) userId;
struct passwd *pw = getpwuid (userId);
Tcl_Obj *resultObj = Tcl_GetObjResult (interp);
char userIdString[16];
if ((pw == NULL) || ((int) uid != userId)) {
sprintf (userIdString, "%d", uid);
Tcl_AppendStringsToObj (resultObj,
"unknown user id: ",
userIdString,
NULL);
endpwent ();
return TCL_ERROR;
}
Tcl_AppendToObj (resultObj, pw->pw_name, -1);
endpwent ();
return TCL_OK;
}
static int GroupnameToGroupidResult (Tcl_Interp *interp, char *groupName)
{
struct group *grp = getgrnam (groupName);
Tcl_Obj *resultObj = Tcl_GetObjResult (interp);
if (grp == NULL) {
Tcl_AppendStringsToObj (resultObj,
"unknown group id: ",
groupName,
(char *) NULL);
return TCL_ERROR;
}
Tcl_SetIntObj (resultObj, grp->gr_gid);
return TCL_OK;
}
static int GroupidToGroupnameResult (Tcl_Interp *interp, int groupId)
{
gid_t gid = (gid_t) groupId;
struct group *grp = getgrgid (groupId);
Tcl_Obj *resultObj = Tcl_GetObjResult (interp);
char groupIdString[16];
sprintf (groupIdString, "%d", gid);
if ((grp == NULL) || ((int) gid != groupId)) {
Tcl_AppendStringsToObj (resultObj,
"unknown group id: ",
groupIdString,
(char *)NULL);
endgrent ();
return TCL_ERROR;
}
Tcl_AppendToObj (resultObj, grp->gr_name, -1);
endgrent ();
return TCL_OK;
}
}
critcl::cproc id_convert_user {Tcl_Interp* interp char* name} ok {
return UsernameToUseridResult (interp, name);
}
critcl::cproc id_convert_userid {Tcl_Interp* interp int uid} ok {
return UseridToUsernameResult (interp, uid);
}
critcl::cproc id_convert_group {Tcl_Interp* interp char* name} ok {
return GroupnameToGroupidResult (interp, name);
}
critcl::cproc id_convert_groupid {Tcl_Interp* interp int gid} ok {
return GroupidToGroupnameResult (interp, gid);
}
critcl::cproc id_effective_user {Tcl_Interp* interp} ok {
return UseridToUsernameResult (interp, geteuid ());
}
critcl::cproc id_effective_userid {Tcl_Interp* interp} ok {
Tcl_SetObjResult (interp, Tcl_NewIntObj (geteuid ()));
return TCL_OK;
}
critcl::cproc id_user {Tcl_Interp* interp} ok {
return UseridToUsernameResult (interp, getuid ());
}
critcl::cproc id_userid {Tcl_Interp* interp} ok {
Tcl_SetObjResult (interp, Tcl_NewIntObj (getuid ()));
return TCL_OK;
}
critcl::cproc id_set_userid {Tcl_Interp* interp int uid} ok {
if (setuid ((uid_t) uid) < 0) {
Tcl_AppendStringsToObj (
Tcl_GetObjResult (interp),
Tcl_PosixError (interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
critcl::cproc id_effective_group {Tcl_Interp* interp} ok {
return GroupidToGroupnameResult (interp, getegid ());
}
critcl::cproc id_effective_groupid {Tcl_Interp* interp} ok {
Tcl_SetObjResult (interp, Tcl_NewIntObj (getegid ()));
return TCL_OK;
}
critcl::cproc id_group {Tcl_Interp* interp} ok {
return GroupidToGroupnameResult (interp, getgid ());
}
critcl::cproc id_groupid {Tcl_Interp* interp} ok {
Tcl_SetObjResult (interp, Tcl_NewIntObj (getgid ()));
return TCL_OK;
}
critcl::cproc id_set_groupid {Tcl_Interp* interp int gid} ok {
if (setgid ((uid_t) gid) < 0) {
Tcl_AppendStringsToObj (
Tcl_GetObjResult (interp),
Tcl_PosixError (interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
critcl::cproc id_process {Tcl_Interp* interp} ok {
Tcl_SetObjResult (interp, Tcl_NewIntObj (getpid ()));
return TCL_OK;
}
critcl::cproc id_process_parent {Tcl_Interp* interp} ok {
Tcl_SetObjResult (interp, Tcl_NewIntObj (getppid ()));
return TCL_OK;
}
critcl::cproc id_process_group {Tcl_Interp* interp} ok {
Tcl_SetObjResult (interp, Tcl_NewIntObj (getpgrp ()));
return TCL_OK;
}
critcl::cproc id_process_group_set {Tcl_Interp* interp int pgid} ok {
int pid;
if (Tcl_IsSafe (interp)) {
Tcl_AppendStringsToObj (
Tcl_GetObjResult (interp),
"can't set process group from a ",
"safe interpeter", (char *) NULL);
return TCL_ERROR;
}
pid = getpid ();
setpgid (pid, pgid);
return TCL_OK;
}
critcl::cproc id_host {Tcl_Interp* interp} ok {
#ifndef MAXHOSTNAMELEN
# define MAXHOSTNAMELEN 256
#endif
char hostNameBuf[MAXHOSTNAMELEN];
if (gethostname (hostNameBuf, MAXHOSTNAMELEN) < 0) {
Tcl_AppendStringsToObj (
Tcl_GetObjResult (interp),
Tcl_PosixError (interp),
(char *) NULL);
return TCL_ERROR;
}
hostNameBuf[MAXHOSTNAMELEN-1] = '\0';
Tcl_SetObjResult (interp, Tcl_NewStringObj (hostNameBuf, -1));
return TCL_OK;
}
critcl::cproc id_groupids {Tcl_Interp* interp} ok {
gid_t *groups;
int nGroups, groupIndex;
Tcl_Obj *newObj;
Tcl_Obj *resultObj = Tcl_GetObjResult (interp);
if (confNGroups < 0)
confNGroups = sysconf (_SC_NGROUPS_MAX);
groups = (gid_t *) ckalloc (confNGroups * sizeof (gid_t));
nGroups = getgroups (confNGroups, groups);
if (nGroups < 0) {
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
Tcl_PosixError (interp), (char *) NULL);
ckfree ((char *) groups);
return TCL_ERROR;
}
for (groupIndex = 0; groupIndex < nGroups; groupIndex++) {
newObj = Tcl_NewIntObj(groups[groupIndex]);
Tcl_ListObjAppendElement (interp,
resultObj,
newObj);
}
ckfree ((char *) groups);
return TCL_OK;
}