tcllauncher-support.tcl.in

#
# tcllauncher-support.tcl - support and standalone routines for tcllauncher
#

package require Tclx

namespace eval ::tcllauncher {

#
# require_group - require a certain group ID, exit with message to stderr if not
#
proc require_group {group} {
    if {[id group] == $group} {
	return
    }

    # see if we can set to that group, maybe we're root?
    if {[catch {id group $group} result] == 1} {
	puts stderr "requires and can't set to group '$group': $result"
	exit 254
    }

    return
}

#
# require_user - require a certain user ID, exit with message to stderr if not
#
proc require_user {user} {
    if {[id user] == $user} {
	return
    }

    # see if we can set to that group, maybe we're root?
    if {[catch {id user $user} result] == 1} {
	puts stderr "requires and can't set to user '$user': $result"
	exit 253
    }

    return
}

#
# require_user_and_group - require the invoker to either be of a certain
#  user and group or if they're superuser or some kind of equivalent,
#  force this process to have the specified user (uid) and group (gid)
#
proc require_user_and_group {user group} {

    # try group first because if we're root we might not be after setting
    # user

    require_group $group

    require_user $user
}

#
# daemonize - rough tclx-based copy of BSD 4.4's "daemon" library routine
#
# usage: daemonize ?-noclose? ?-nochdir?
#
# detaches the process from the controlling terminal by forking, having
# the child become a process group leader, changing directory to / (by
# default) and closing and reopening stdin, stdout and stderr to and
# from /dev/null.
#
proc daemonize {args} {
    set doClose 1
    set doChdir 1

    foreach arg $args {
        switch $arg {
	    "-noclose" {
	        set doClose 0
	    }

	    "-nochdir" {
	        set doChdir 0
	    }

	    default {
	        error "unrecognized option: $arg"
	    }
	}
    }

    set pid [fork]

    if {$pid != 0} {
        exit 0
    }

    id process group set

    if {$doChdir} {
        cd "/"
    }

    if {$doClose} {
	# they didn't say -noclose so close stdin, stdout, stderr and
	# repoint to /dev/null
        set fp [open /dev/null RDWR]
	dup $fp stdin
	dup $fp stdout
	dup $fp stderr
	close $fp
    } else {
	# they set -noclose but let's make sure stdin, stdout and stderr
	# exist and if they don't, let's gin them up from /dev/null
	if {[llength [file channels std*]] == 3} {
	    # they all exist, we're good
	    return
	}

	set fp [open /dev/null RDWR]
	# regenerate the list of standard handles because the fp file we
	# just opened will have become one of them by opening it
	set stdHandles [file channels std*]

	# for all the stdio handles that don't have some kind of file
	# or socket or device associated with them, associate /dev/null
	foreach handle [list stdin stdout stderr] {
	# if the handle doesn't exist...
	    if {[lsearch $stdHandles $handle] < 0} {
		dup $fp $handle
	    }
	}
	close $fp
    }

    return
}

#
# pidfile_verify - insane checks of pid file
#
proc pidfile_verify {} {
    variable pfh

    if {[catch {fstat $pfh(fp)} stat] == 1} {
        error "programming error"
    }

    set dev [keylget stat dev]
    set ino [keylget stat ino]

    if {$dev != $pfh(dev) || $ino != $pfh(ino)} {
        error "programming error"
    }

    return 0
}

#
# pidfile_read - given a path and the name of a pid variable, set the
#  PID into the variable
#
proc pidfile_read {path _pid} {
    variable pfh

    upvar $_pid pid

    set fp [open $path "RDONLY"]
    set pid [read -nonewline $fp]
    close $fp

    set pfh(path) $path
}

#
# pidfile_open - given an optional path to a file and optional permissions,
#  open the file, try to lock it, get its contents.  Return the pid contained
#  therein if there is one and the lock failed.  (Somebody's already got the
#  pid.)
#
#  else you've got the lock and call pidfile_write to get your pid in there
#
proc pidfile_open {{path ""} {mode 0600}} {
    variable pfh

    if {$path == ""} {
        set pidfile /var/run/$::argv0.pid
    } else {
        set pidfile $path
    }

    set pfh(path) $pidfile

    # Open the PID file and obtain exclusive lock.
    # We truncate PID file here only to remove old PID immediately,
    # PID file will be truncated again in pidfile_write(), so
    # pidfile_write() can be called multiple times.

    set fp [open $pidfile "RDWR CREAT" $mode]

    # try to lock the file

    if {![flock -write -nowait $fp]} {
        # failed to lock the file, read it for the pid of the owner
        set pid [read -nonewline $fp]

		# if we can get an integer out of it, return that
		if {[scan $pid %d pid] > 0} {
		    close $fp
		    return $pid
		}
    }

    # i got the lock

    # can fstat really fail on a file i have open?
    set stat [fstat $fp]

    set pfh(fp) $fp
    set pfh(dev) [keylget stat dev]
    set pfh(ino) [keylget stat ino]

    return 0
}

#
# pidfile_mtime - return the mtime of the pidfile, returns -1 if
#   "file mtime" failed.
#
proc pidfile_mtime {} {
    variable pfh

    if {[catch {file mtime $pfh(path)} catchResult] == 1} {
	# some kind of error statting the file
        return -1
    }

    # catchResult is the mtime of the file
    return $catchResult
}

#
# pidfile_write - write my pid into the pid file
#
proc pidfile_write {} {
    variable pfh

    pidfile_verify

    set fp $pfh(fp)

    if {![flock -write -nowait $fp]} {
		puts stderr "Unable to obtain lock on pidfile for pidfile_write"
		exit 252
	}

    ftruncate -fileid $fp 0

    puts $fp [pid]
    flush $fp
}

#
# pidfile_close - close the pid file
#
proc pidfile_close {} {
    variable pfh

    pidfile_verify

    close $pfh(fp)
}

#
# pidfile_remove - remove the pidfile, unlock the lock, and close it
#
proc pidfile_remove {} {
    variable pfh

    pidfile_verify

    file delete $pfh(path)
    funlock $pfh(fp)

    close $pfh(fp)
}

} ;# namespace tcllauncher

package provide @PACKAGE_NAME@ @PACKAGE_VERSION@

# vim: set ts=8 sw=4 sts=4 noet :