/* This function is used instead of the snack_sndfile_ext.tcl script in order
to generate the tcl variables that are needed by snack. Doing it here allows
keeping the formats always up to date with the current version of libsndfile
*/
int CreateTclVariablesForSnack(Tcl_Interp *interp)
{
int k, count ;
SF_FORMAT_INFO format_info ;
Tcl_Obj *scriptPtr = Tcl_NewStringObj("", 0);
Tcl_Obj *scriptPtr1 = Tcl_NewStringObj("", 0);
Tcl_Obj *scriptPtr2 = Tcl_NewStringObj("", 0);
Tcl_Obj *formatExtUC = Tcl_NewStringObj("", 0);
Tcl_AppendStringsToObj(scriptPtr,
"namespace eval snack::snack_sndfile_ext {\n",
" variable extTypes\n",
" variable loadTypes\n",
" variable loadKeys\n\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr1, " set extTypesMC {\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr2, " set loadTypes {\n", (char *) NULL);
sf_command (NULL, SFC_GET_FORMAT_MAJOR_COUNT, &count, sizeof (int));
for (k = 0 ; k < count ; k++) {
format_info.format = k ;
sf_command (NULL, SFC_GET_FORMAT_MAJOR, &format_info, sizeof (SF_FORMAT_INFO));
/* convert extension to upper case */
Tcl_SetStringObj(formatExtUC, format_info.extension, strlen(format_info.extension));
Tcl_UtfToUpper(Tcl_GetString(formatExtUC));
/* append to variable extTypesMC */
Tcl_AppendStringsToObj(scriptPtr1, " {{", format_info.name,
"} .", format_info.extension, "}\n", (char *) NULL);
/* append to variable loadTypes */
Tcl_AppendStringsToObj(scriptPtr2, " {{", format_info.name,
"} {.", format_info.extension,
" .", Tcl_GetString(formatExtUC),
"}}\n", (char *) NULL);
}
Tcl_AppendStringsToObj(scriptPtr1, " }\n\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr2, " }\n\n", (char *) NULL);
Tcl_AppendObjToObj(scriptPtr, scriptPtr1);
Tcl_AppendObjToObj(scriptPtr, scriptPtr2);
Tcl_AppendStringsToObj(scriptPtr,
" set extTypes [list]\n",
" set loadKeys [list]\n",
" foreach pair $extTypesMC {\n",
" set type [string toupper [lindex $pair 0]]\n",
" set ext [lindex $pair 1]\n",
" lappend extTypes [list $type $ext]\n",
" lappend loadKeys $type\n"
" }\n\n",
" snack::addLoadTypes $loadTypes $loadKeys\n",
" snack::addExtTypes $extTypes\n",
"}\n", (char *) NULL);
/* fprintf(stderr, "%s\n", Tcl_GetString(scriptPtr)); */
return Tcl_EvalObjEx(interp, scriptPtr, TCL_EVAL_DIRECT);
}
static HRESULT
Async(
TkWinSendCom *obj,
VARIANT Cmd,
EXCEPINFO *pExcepInfo,
UINT *puArgErr)
{
HRESULT hr = S_OK;
int result = TCL_OK;
VARIANT vCmd;
VariantInit(&vCmd);
hr = VariantChangeType(&vCmd, &Cmd, 0, VT_BSTR);
if (FAILED(hr)) {
Tcl_SetStringObj(Tcl_GetObjResult(obj->interp),
"invalid args: Async(command)", -1);
SetExcepInfo(obj->interp, pExcepInfo);
hr = DISP_E_EXCEPTION;
}
if (SUCCEEDED(hr)) {
if (obj->interp) {
Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(vCmd.bstrVal,
(int)SysStringLen(vCmd.bstrVal));
result = TkWinSend_QueueCommand(obj->interp, scriptPtr);
}
}
VariantClear(&vCmd);
return hr;
}
SEXP RTcl_ObjFromCharVector(SEXP args)
{
char *s;
Tcl_DString s_ds;
int count;
Tcl_Obj *tclobj, *elem;
int i;
SEXP val, drop;
Tcl_Encoding encoding;
const void *vmax = vmaxget();
val = CADR(args);
drop = CADDR(args);
tclobj = Tcl_NewObj();
count = length(val);
encoding = Tcl_GetEncoding(RTcl_interp, "utf-8");
if (count == 1 && LOGICAL(drop)[0]) {
Tcl_DStringInit(&s_ds);
s = Tcl_ExternalToUtfDString(encoding,
translateCharUTF8(STRING_ELT(val, 0)),
-1, &s_ds);
Tcl_SetStringObj(tclobj, s, -1);
Tcl_DStringFree(&s_ds);
} else
for ( i = 0 ; i < count ; i++) {
elem = Tcl_NewObj();
Tcl_DStringInit(&s_ds);
s = Tcl_ExternalToUtfDString(encoding,
translateCharUTF8(STRING_ELT(val, i)),
-1, &s_ds);
Tcl_SetStringObj(elem, s, -1);
Tcl_DStringFree(&s_ds);
Tcl_ListObjAppendElement(RTcl_interp, tclobj, elem);
}
Tcl_FreeEncoding(encoding);
SEXP res = makeRTclObject(tclobj);
vmaxset(vmax);
return res;
}
static int
map_arg_registers (Tcl_Interp *interp, int objc, Tcl_Obj **objv,
map_func func, map_arg arg)
{
int regnum, numregs;
/* Note that the test for a valid register must include checking the
gdbarch_register_name because gdbarch_num_regs may be allocated for
the union of the register sets within a family of related processors.
In this case, some entries of gdbarch_register_name will change
depending upon the particular processor being debugged. */
numregs = (gdbarch_num_regs (get_current_arch ())
+ gdbarch_num_pseudo_regs (get_current_arch ()));
if (objc == 0) /* No args, just do all the regs */
{
result_ptr->flags |= GDBTK_MAKES_LIST;
for (regnum = 0; regnum < numregs; regnum++)
{
if (gdbarch_register_name (get_current_arch (), regnum) == NULL
|| *(gdbarch_register_name (get_current_arch (), regnum)) == '\0')
continue;
func (regnum, arg);
}
return TCL_OK;
}
if (objc == 1)
if (Tcl_ListObjGetElements (interp, *objv, &objc, &objv ) != TCL_OK)
return TCL_ERROR;
if (objc > 1)
result_ptr->flags |= GDBTK_MAKES_LIST;
/* Else, list of register #s, just do listed regs */
for (; objc > 0; objc--, objv++)
{
if (Tcl_GetIntFromObj (NULL, *objv, ®num) != TCL_OK)
{
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
return TCL_ERROR;
}
if (regnum >= 0 && regnum < numregs)
func (regnum, arg);
else
{
Tcl_SetStringObj (result_ptr->obj_ptr, "bad register number", -1);
return TCL_ERROR;
}
}
return TCL_OK;
}
static OSErr
OpenLibraryResource(
struct CFragInitBlock* initBlkPtr)
{
/*
* The 3.0 version of the Universal headers changed CFragInitBlock
* to an opaque pointer type. CFragSystem7InitBlock is now the
* real pointer.
*/
#if !defined(UNIVERSAL_INTERFACES_VERSION) || (UNIVERSAL_INTERFACES_VERSION < 0x0300)
struct CFragInitBlock *realInitBlkPtr = initBlkPtr;
#else
CFragSystem7InitBlock *realInitBlkPtr = (CFragSystem7InitBlock *) initBlkPtr;
#endif
FSSpec* fileSpec = NULL;
OSErr err = noErr;
if (realInitBlkPtr->fragLocator.where == kDataForkCFragLocator) {
fileSpec = realInitBlkPtr->fragLocator.u.onDisk.fileSpec;
} else if (realInitBlkPtr->fragLocator.where == kResourceCFragLocator) {
fileSpec = realInitBlkPtr->fragLocator.u.inSegs.fileSpec;
} else {
err = resFNotFound;
}
/*
* Open the resource fork for this library in read-only mode.
* This will make it the current res file, ahead of the
* application's own resources.
*/
if (fileSpec != NULL) {
ourResFile = FSpOpenResFile(fileSpec, fsRdPerm);
if (ourResFile == kResFileNotOpened) {
err = ResError();
} else {
#ifdef TCL_REGISTER_LIBRARY
ourResToken = Tcl_NewObj();
Tcl_IncrRefCount(ourResToken);
p2cstr(realInitBlkPtr->libName);
Tcl_SetStringObj(ourResToken, (char *) realInitBlkPtr->libName, -1);
c2pstr((char *) realInitBlkPtr->libName);
TclMacRegisterResourceFork(ourResFile, ourResToken,
TCL_RESOURCE_DONT_CLOSE);
#endif
SetResFileAttrs(ourResFile, mapReadOnly);
}
}
return err;
}
/*++
TclSetOctalObj
Sets the object to an octal value.
Arguments:
objPtr - Object to replace.
octal - The octal value to use.
Return Value:
None.
--*/
void
TclSetOctalObj(
Tcl_Obj *objPtr,
unsigned long octal
)
{
char value[12];
assert(objPtr != NULL);
StringCchPrintfA(value, ARRAYSIZE(value), "%03lo", octal);
Tcl_SetStringObj(objPtr, value, -1);
}
void QMetaTclQVariant::dupInternalRep(Tcl_Obj *src, Tcl_Obj *copy)
{
// create a new QMetaTclQVariant object
QMetaTclQVariant *thiz =
static_cast<QMetaTclQVariant *>(src->internalRep.twoPtrValue.ptr1);
Tcl_SetStringObj(copy, generateCommandName(thiz->m_interp), -1);
if (copy->typePtr && copy->typePtr->freeIntRepProc)
copy->typePtr->freeIntRepProc(copy);
copy->internalRep.twoPtrValue.ptr1 = new QMetaTclQVariant(
thiz->m_qvariant, thiz->m_interp, Tcl_GetString(copy));
copy->internalRep.twoPtrValue.ptr2 = NULL;
copy->typePtr = &TclType;
}
static int
GetOp(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv)
{
Tk_Window tkwin = clientData;
char *string;
int buffer;
int nBytes;
buffer = 0;
if (objc == 3) {
if (GetCutNumberFromObj(interp, objv[2], &buffer) != TCL_OK) {
return TCL_ERROR;
}
}
string = XFetchBuffer(Tk_Display(tkwin), &nBytes, buffer);
if (string != NULL) {
int limit;
char *p;
int i;
if (string[nBytes - 1] == '\0') {
limit = nBytes - 1;
} else {
limit = nBytes;
}
for (p = string, i = 0; i < limit; i++, p++) {
int c;
c = (unsigned char)*p;
if (c == 0) {
*p = ' '; /* Convert embedded NUL bytes */
}
}
if (limit == nBytes) {
char *newPtr;
/*
* Need to copy the string into a bigger buffer so we can
* add a NUL byte on the end.
*/
newPtr = Blt_AssertMalloc(nBytes + 1);
memcpy(newPtr, string, nBytes);
newPtr[nBytes] = '\0';
Blt_Free(string);
string = newPtr;
}
Tcl_SetStringObj(Tcl_GetObjResult(interp), string, nBytes);
}
return TCL_OK;
}
static void
setBrlapiError (Tcl_Interp *interp) {
const char *text = brlapi_strerror(&brlapi_error);
const char *name;
int number;
switch (brlapi_error.brlerrno) {
case BRLAPI_ERROR_LIBCERR:
name = "LIBC";
number = brlapi_error.libcerrno;
break;
case BRLAPI_ERROR_GAIERR:
name = "GAI";
number = brlapi_error.gaierrno;
break;
default:
name = "BRL";
number = brlapi_error.brlerrno;
break;
}
{
Tcl_Obj *const elements[] = {
Tcl_NewStringObj("BrlAPI", -1),
Tcl_NewStringObj(name, -1),
Tcl_NewIntObj(number),
Tcl_NewStringObj(text, -1)
};
Tcl_SetObjErrorCode(interp, Tcl_NewListObj(4, elements));
}
Tcl_Obj *result = Tcl_GetObjResult(interp);
Tcl_SetStringObj(result, "BrlAPI error: ", -1);
size_t length = strlen(text);
while (length > 0) {
size_t end = length - 1;
if (text[end] != '\n') break;
length = end;
}
Tcl_AppendToObj(result, text, length);
}
void
TnmSnmpLocalizeKey(int algorithm, Tcl_Obj *authKey, Tcl_Obj *engineID, Tcl_Obj *localAuthKey)
{
unsigned char *engineBytes, *authKeyBytes;
int engineLength, authKeyLength, localAuthKeyLength = 20;
unsigned char localAuthKeyBytes[20]; /* must be big enough for MD5 and SHA */
authKeyBytes = (unsigned char *) Tcl_GetStringFromObj(authKey, &authKeyLength);
engineBytes = (unsigned char *) Tcl_GetStringFromObj(engineID, &engineLength);
/*
* Localize a key as described in section 2.6 of RFC 2274.
*/
switch (algorithm) {
case TNM_SNMP_AUTH_MD5: {
MD5_CTX MD;
TnmMD5Init(&MD);
TnmMD5Update(&MD, authKeyBytes, authKeyLength);
TnmMD5Update(&MD, engineBytes, engineLength);
TnmMD5Update(&MD, authKeyBytes, authKeyLength);
Tcl_SetObjLength(localAuthKey, 16);
TnmMD5Final(localAuthKeyBytes, &MD);
break;
}
case TNM_SNMP_AUTH_SHA: {
SHA_CTX SH;
TnmSHAInit(&SH);
TnmSHAUpdate(&SH, authKeyBytes, authKeyLength);
TnmSHAUpdate(&SH, engineBytes, engineLength);
TnmSHAUpdate(&SH, authKeyBytes, authKeyLength);
TnmSHAFinal(localAuthKeyBytes, &SH);
break;
}
default:
Tcl_Panic("unknown algorithm for key localization");
}
Tcl_SetStringObj(localAuthKey, (char *) localAuthKeyBytes, localAuthKeyLength);
}
static void
SetAttributeObj (Tcl_Obj * const objPtr, DBFHandle const dbfHandle,
int const record, int const field)
{
if (DBFIsAttributeNULL (dbfHandle, record, field))
{
return;
}
switch (DBFGetFieldInfo (dbfHandle, field, NULL, NULL, NULL))
{
case FTInteger:
Tcl_SetIntObj (objPtr,
DBFReadIntegerAttribute (dbfHandle, record, field));
break;
case FTDouble:
Tcl_SetDoubleObj (objPtr,
DBFReadDoubleAttribute (dbfHandle, record, field));
break;
default:
Tcl_SetStringObj (objPtr,
DBFReadStringAttribute (dbfHandle, record, field), -1);
}
}
/* This is the worker routing for the threads that process the
* substitution of the nucleic acid codes with their meanings. These
* threads are not in a thread pool because the work can be divided
* exactly into one thread per cpu. So the parent just starts each
* thread and waits for them all to finish.
*
* Each worker gets a range of characters from the main input string
* and is responsible for calling regsub() once for each nucleic acid
* code. Thus, if there are 11 nucleic acid codes, each thread calls
* regsub() 11 times but the scope of the regsub() call is limited to
* just the range of characters it has been assigned. */
static void*
process_nacodes_worker(nacodes_worker_data_t data)
{
char* s_in = NULL;
char* s_out = NULL;
struct nucleic_acid_code* nacode = NULL;
/* Get the character range as a C-style string. */
s_in = Tcl_GetString(data->range);
/* Iterate over the nucleic acid codes. */
for (nacode = nacodes ; nacode->code ; ++nacode) {
/* Perform the substitution. */
s_out = regsub(nacode->code, s_in, nacode->meaning, NULL);
/* Free s_in on all but the first pass because s_in
* belongs to Tcl on the first pass. */
if (nacode != nacodes) {
g_free(s_in);
s_in = NULL;
}
/* If this is the last pass, save the result and clean up. */
if ((nacode + 1)->code == NULL) {
Tcl_SetStringObj(data->range, s_out, strlen(s_out));
g_free(s_out);
s_out = NULL;
} else {
/* Otherwise, prepare for the next iteration. */
s_in = s_out;
s_out = NULL;
}
}
return NULL;
}
int
sn_indent_outdent (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *objv[])
{
char *txt;
int indent = 1;
int indentsize= 8;
int tabsize = 8;
int repl_tabs = 0;
char *group = "";
int i, j;
char *result, *p, *q, *beg;
char tabstr[64], lastchar;
int error = 0;
Tcl_Obj *cmd = NULL;
Tcl_Obj *resultPtr;
for (i=1; i<argc; i++)
{
if (strcmp ("-indent", Tcl_GetStringFromObj (objv[i], NULL)) == 0)
{
i++;
if (strcmp (Tcl_GetStringFromObj (objv[i], NULL), "indent") == 0)
indent = 1;
else
indent = 0;
}
else if (strcmp ("-indentwidth", Tcl_GetStringFromObj (objv[i], NULL)) == 0)
{
i++;
indentsize = atoi (Tcl_GetStringFromObj (objv[i], NULL));
}
else if (strcmp ("-tabwidth", Tcl_GetStringFromObj (objv[i], NULL)) == 0)
{
i++;
tabsize = atoi (Tcl_GetStringFromObj (objv[i], NULL));
}
else if (strcmp ("-replacetabs", Tcl_GetStringFromObj (objv[i], NULL)) == 0)
{
i++;
repl_tabs = atoi (Tcl_GetStringFromObj (objv[i], NULL));
}
else if (strcmp ("-group", Tcl_GetStringFromObj (objv[i], NULL)) == 0)
{
i++;
group = Tcl_GetStringFromObj (objv[i], NULL);
}
else if (strcmp ("-command", Tcl_GetStringFromObj (objv[i], NULL)) == 0)
{
i++;
cmd = objv[i];
}
else if (strcmp ("--", Tcl_GetStringFromObj (objv[i], NULL)) == 0)
{
break;
}
else if (Tcl_GetStringFromObj (objv[i], NULL)[0] != '-')
{
break; /* end of argument list */
}
else
{
error = 1;
break;
}
}
if (error || i >= argc)
{
Tcl_WrongNumArgs (interp, 1, objv,
"?-indent indent|outdent? "
"?-indentwidth value? "
"?-tabwidth value? "
"?-replacetabs yes/no? "
"?-group group? "
"?-command command? "
"string");
return TCL_ERROR;
}
txt = Tcl_GetStringFromObj (objv[i], NULL);
/*
* empty string */
if (*txt == 0)
return TCL_OK;
resultPtr = Tcl_NewObj();
result = ckalloc (8 + strlen (txt) * 8); result[0] = 0;
/*
* init a tabstring, based on the tabsize */
for (i=0; i<tabsize; i++)
{
tabstr[i] = ' ';
}
tabstr[i] = 0;
/*
* Indent is pretty easy */
if (indent)
{
for (p=txt, q=result; *p; p++)
{
/*
* In c++ mode skip macro lines beginning with "#" */
if (*p == '#' && strcmp (group, "c++") == 0)
{
while (*p && *p != '\n')
{
*q ++ = *p++;
}
*q ++ = *p;
continue;
}
beg = q;
/*
* copy remaining spaces/tabs */
while (*p == ' ' || *p == '\t')
{
*q ++ = *p ++;
}
/*
* skip empty lines, even the lines contain only spaces or/and tabs */
if (*p == '\n' || *p == 0)
{
*q ++ = *p;
if (*p == 0)
break;
continue;
}
/*
* insert indention */
if (repl_tabs == 0 && tabsize == indentsize)
{
*q++ = '\t';
}
else
{
for (j=0; j<indentsize; j++)
*q++ = ' ';
}
*q = 0;
/*
* replace spaces with tabs, if there are more spaces
* following with tab size */
if (! repl_tabs)
{
q = filter_spaces_from_tabs (tabsize, beg);
}
/*
* copy the rest of the line */
while (*p && *p != '\n')
{
*q ++ = *p++;
}
*q ++ = *p;
if (*p == 0)
break;
}
*q = 0;
goto done;
}
/*
* do outdenting */
for (p=txt, q=result; *p;)
{
beg = q;
/*
* skip leading ' ' and '\t' */
while (*p == ' ' || *p == '\t')
*q ++ = *p ++;
*q = 0;
/*
* what was the last character? */
if (q > beg)
lastchar = *(q-1);
else
lastchar = 0;
/*
* translate too much blanks into tabs */
if (! repl_tabs)
{
q = filter_spaces_from_tabs (tabsize, beg);
}
/*
* go back on step */
if (!repl_tabs && tabsize == indentsize && lastchar == '\t')
{
q --;
}
else if (lastchar > 0)
{
/*
* go back so many indent size */
for (i=0; i<=indentsize; i++)
{
if (*q == '\t')
{
/*
* replace tab with so many spaces like the tabsize
* last tab must be even replaced */
memmove (q+tabsize, q+1, strlen (q));
strncpy (q, tabstr, tabsize);
q += tabsize-1;
}
if (i<indentsize && q > beg)
q --;
}
}
else
{
/* line begins with strings */
}
/*
* copy rest of line */
while (*p && *p != '\n')
{
*q ++ = *p ++;
}
*q ++ = *p;
*q = 0;
if (*p != 0)
{
p++;
}
}
done:
Tcl_SetStringObj (resultPtr, result, -1);
Tcl_SetObjResult (interp, resultPtr);
ckfree (result);
return TCL_OK;
}
int
Tk_SendObjCmd(
ClientData clientData, /* Information about sender (only dispPtr
* field is used). */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
enum {
SEND_ASYNC, SEND_DISPLAYOF, SEND_LAST
};
static const char *sendOptions[] = {
"-async", "-displayof", "--", NULL
};
int result = TCL_OK;
int i, optind, async = 0;
Tcl_Obj *displayPtr = NULL;
/*
* Process the command options.
*/
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions,
"option", 0, &optind) != TCL_OK) {
break;
}
if (optind == SEND_ASYNC) {
++async;
} else if (optind == SEND_DISPLAYOF) {
displayPtr = objv[++i];
} else if (optind == SEND_LAST) {
i++;
break;
}
}
/*
* Ensure we still have a valid command.
*/
if ((objc - i) < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-async? ?-displayof? ?--? interpName arg ?arg ...?");
result = TCL_ERROR;
}
/*
* We don't support displayPtr. See TIP #150.
*/
if (displayPtr) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"option not implemented: \"displayof\" is not available "
"for this platform.", -1);
result = TCL_ERROR;
}
/*
* Send the arguments to the foreign interp.
*/
/* FIX ME: we need to check for local interp */
if (result == TCL_OK) {
LPDISPATCH pdisp;
result = FindInterpreterObject(interp, Tcl_GetString(objv[i]), &pdisp);
if (result == TCL_OK) {
i++;
result = Send(pdisp, interp, async, clientData, objc-i, objv+i);
pdisp->lpVtbl->Release(pdisp);
}
}
return result;
}
int
main(int argc,
char* argv[])
{
int rv = 0;
int cpu_count = 0;
int init_length = 0;
int code_length = 0;
int seq_length = 0;
char* s_cstr = NULL;
Tcl_Interp *tcl = NULL;
Tcl_Obj* s = NULL;
/* Initialize Tcl. */
Tcl_FindExecutable(argv[0]);
tcl = Tcl_CreateInterp();
Tcl_Preserve((ClientData)tcl);
/* Count the number of cpus. If the cpu count could not be
* determined, assume 4 cpus. */
cpu_count = get_cpu_count();
if (!cpu_count) {
cpu_count = 4;
}
/* Allocate s. */
s = Tcl_NewStringObj("", 0);
Tcl_IncrRefCount(s);
/* Load stdin into s. */
load_file(stdin, s);
/* Get the length of s. */
init_length = Tcl_GetCharLength(s);
/* Strip off section headers and EOLs from s. This is a little
* messy because we have to go from Tcl-string to C-string and
* back to Tcl-string. */
s_cstr = regsub("(>.*)|\n", Tcl_GetString(s), "", NULL);
Tcl_SetStringObj(s, s_cstr, strlen(s_cstr));
g_free(s_cstr);
s_cstr = NULL;
/* Get the length of s. */
code_length = Tcl_GetCharLength(s);
/* Process the variants by counting them and printing the results. */
process_variants(cpu_count, s);
/* Substitute nucleic acid codes in s with their meanings. */
process_nacodes(cpu_count, s);
/* Get the length of s. */
seq_length = Tcl_GetCharLength(s);
/* Print the lengths. */
printf("\n%d\n%d\n%d\n", init_length, code_length, seq_length);
/* Clean up. */
Tcl_DecrRefCount(s);
/* Finalize Tcl. */
Tcl_Release((ClientData)tcl);
Tcl_Exit(rv);
/* Not reached. */
return rv;
}
static void
setStringResult (Tcl_Interp *interp, const char *string, int length) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), string, length);
}
/* ARGSUSED */
int
Tcl_ScanObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *format;
int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, result, code;
long value;
const char *string, *end, *baseString;
char op = 0;
int width, underflow = 0;
Tcl_WideInt wideValue;
Tcl_UniChar ch, sch;
Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
char buf[513]; /* Temporary buffer to hold scanned number
* strings before they are passed to
* strtoul. */
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"string format ?varName ...?");
return TCL_ERROR;
}
format = Tcl_GetStringFromObj(objv[2], NULL);
numVars = objc-3;
/*
* Check for errors in the format string.
*/
if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Allocate space for the result objects.
*/
if (totalVars > 0) {
objs = ckalloc(sizeof(Tcl_Obj *) * totalVars);
for (i = 0; i < totalVars; i++) {
objs[i] = NULL;
}
}
string = Tcl_GetStringFromObj(objv[1], NULL);
baseString = string;
/*
* Iterate over the format string filling in the result objects until we
* reach the end of input, the end of the format string, or there is a
* mismatch.
*/
objIndex = 0;
nconversions = 0;
while (*format != '\0') {
int parseFlag = TCL_PARSE_NO_WHITESPACE;
format += Tcl_UtfToUniChar(format, &ch);
flags = 0;
/*
* If we see whitespace in the format, skip whitespace in the string.
*/
if (Tcl_UniCharIsSpace(ch)) {
offset = Tcl_UtfToUniChar(string, &sch);
while (Tcl_UniCharIsSpace(sch)) {
if (*string == '\0') {
goto done;
}
string += offset;
offset = Tcl_UtfToUniChar(string, &sch);
}
continue;
}
if (ch != '%') {
literal:
if (*string == '\0') {
underflow = 1;
goto done;
}
string += Tcl_UtfToUniChar(string, &sch);
if (ch != sch) {
goto done;
}
continue;
}
format += Tcl_UtfToUniChar(format, &ch);
if (ch == '%') {
goto literal;
}
/*
* Check for assignment suppression ('*') or an XPG3-style assignment
* ('%n$').
*/
if (ch == '*') {
flags |= SCAN_SUPPRESS;
format += Tcl_UtfToUniChar(format, &ch);
} else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
char *formatEnd;
value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
if (*formatEnd == '$') {
format = formatEnd+1;
format += Tcl_UtfToUniChar(format, &ch);
objIndex = (int) value - 1;
}
}
/*
* Parse any width specifier.
*/
if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */
format += Tcl_UtfToUniChar(format, &ch);
} else {
width = 0;
}
/*
* Handle any size specifier.
*/
switch (ch) {
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += Tcl_UtfToUniChar(format, &ch);
break;
}
case 'L':
flags |= SCAN_LONGER;
/*
* Fall through so we skip to the next character.
*/
case 'h':
format += Tcl_UtfToUniChar(format, &ch);
}
/*
* Handle the various field types.
*/
switch (ch) {
case 'n':
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj(string - baseString);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
nconversions++;
continue;
case 'd':
op = 'i';
parseFlag |= TCL_PARSE_DECIMAL_ONLY;
break;
case 'i':
op = 'i';
parseFlag |= TCL_PARSE_SCAN_PREFIXES;
break;
case 'o':
op = 'i';
parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES;
break;
case 'x':
case 'X':
op = 'i';
parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY;
break;
case 'b':
op = 'i';
parseFlag |= TCL_PARSE_BINARY_ONLY;
break;
case 'u':
op = 'i';
parseFlag |= TCL_PARSE_DECIMAL_ONLY;
flags |= SCAN_UNSIGNED;
break;
case 'f':
case 'e':
case 'E':
case 'g':
case 'G':
op = 'f';
break;
case 's':
op = 's';
break;
case 'c':
op = 'c';
flags |= SCAN_NOSKIP;
break;
case '[':
op = '[';
flags |= SCAN_NOSKIP;
break;
}
/*
* At this point, we will need additional characters from the string
* to proceed.
*/
if (*string == '\0') {
underflow = 1;
goto done;
}
/*
* Skip any leading whitespace at the beginning of a field unless the
* format suppresses this behavior.
*/
if (!(flags & SCAN_NOSKIP)) {
while (*string != '\0') {
offset = Tcl_UtfToUniChar(string, &sch);
if (!Tcl_UniCharIsSpace(sch)) {
break;
}
string += offset;
}
if (*string == '\0') {
underflow = 1;
goto done;
}
}
/*
* Perform the requested scanning operation.
*/
switch (op) {
case 's':
/*
* Scan a string up to width characters or whitespace.
*/
if (width == 0) {
width = ~0;
}
end = string;
while (*end != '\0') {
offset = Tcl_UtfToUniChar(end, &sch);
if (Tcl_UniCharIsSpace(sch)) {
break;
}
end += offset;
if (--width == 0) {
break;
}
}
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewStringObj(string, end-string);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
string = end;
break;
case '[': {
CharSet cset;
if (width == 0) {
width = ~0;
}
end = string;
format = BuildCharSet(&cset, format);
while (*end != '\0') {
offset = Tcl_UtfToUniChar(end, &sch);
if (!CharInSet(&cset, (int)sch)) {
break;
}
end += offset;
if (--width == 0) {
break;
}
}
ReleaseCharSet(&cset);
if (string == end) {
/*
* Nothing matched the range, stop processing.
*/
goto done;
}
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewStringObj(string, end-string);
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
string = end;
break;
}
case 'c':
/*
* Scan a single Unicode character.
*/
string += Tcl_UtfToUniChar(string, &sch);
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewIntObj((int)sch);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
case 'i':
/*
* Scan an unsigned or signed integer.
*/
objPtr = Tcl_NewLongObj(0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_INTEGER_ONLY | parseFlag)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
underflow = 1;
}
}
goto done;
}
string = end;
if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
break;
}
if (flags & SCAN_LONGER) {
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */
if (TclGetString(objPtr)[0] == '-') {
wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
sprintf(buf, "%" TCL_LL_MODIFIER "u",
(Tcl_WideUInt)wideValue);
Tcl_SetStringObj(objPtr, buf, -1);
} else {
Tcl_SetWideIntObj(objPtr, wideValue);
}
} else if (!(flags & SCAN_BIG)) {
if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
} else {
value = LONG_MAX;
}
}
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
sprintf(buf, "%lu", value); /* INTL: ISO digit */
Tcl_SetStringObj(objPtr, buf, -1);
} else {
Tcl_SetLongObj(objPtr, value);
}
}
objs[objIndex++] = objPtr;
break;
case 'f':
/*
* Scan a floating point number
*/
objPtr = Tcl_NewDoubleObj(0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
underflow = 1;
}
}
goto done;
} else if (flags & SCAN_SUPPRESS) {
Tcl_DecrRefCount(objPtr);
string = end;
} else {
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
if (objPtr->typePtr == &tclDoubleType) {
dvalue = objPtr->internalRep.doubleValue;
} else
#endif
{
Tcl_DecrRefCount(objPtr);
goto done;
}
}
Tcl_SetDoubleObj(objPtr, dvalue);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
string = end;
}
}
void
Tcl_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *resultPtr, *argvPtr, *appName, *LObj;
int commandLen;
char *commandStr;
const char *encodingName = NULL;
int code, exitCode = 0, isL = 0;
Tcl_MainLoopProc *mainLoopProc;
Tcl_Channel chan;
InteractiveState is;
TclpSetInitialEncodings();
TclpFindExecutable((const char *)argv[0]);
Tcl_InitMemory(interp);
is.interp = interp;
is.prompt = PROMPT_START;
is.commandPtr = Tcl_NewObj();
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
/*
* Check whether initial args (argv[1] and beyond) look like
* -encoding ENCODING FILENAME
* or like
* [-opt1] [-opt2] ... [-optn] FILENAME
*/
/* Create argv list obj for L. */
L->global->tclsh_argc = 1;
L->global->tclsh_argv = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, L->global->tclsh_argv,
NewNativeObj(argv[0], -1));
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if (argc > 1) {
/* Pass over all options to look for a file name. */
int i;
Tcl_Obj *argObj;
for (i = 1; i < argc; ++i) {
argObj = NewNativeObj(argv[i], -1);
Tcl_ListObjAppendElement(NULL, L->global->tclsh_argv, argObj);
++L->global->tclsh_argc;
if ('-' != argv[i][0]) {
Tcl_SetStartupScript(argObj, NULL);
argc -= i;
argv += i;
break;
} else if (!_tcscmp(argv[i], TEXT("--version")) ||
!_tcscmp(argv[i], TEXT("-version"))) {
if (strlen(L_VER_TAG)) {
printf("L version is %s %s for %s\n",
L_VER_TAG, L_VER_UTC, L_VER_PLATFORM);
} else {
printf("L version is %s for %s\n",
L_VER_UTC, L_VER_PLATFORM);
}
printf("Built by: %s\n", L_VER_USER);
printf("Built in: %s\n", L_VER_PWD);
printf("Built on: %s\n", L_VER_BUILD_TIME);
exit(0);
}
}
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0], -1);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
L->global->script_argc = argc;
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
L->global->script_argv = argvPtr;
Tcl_IncrRefCount(argvPtr);
/*
* Set the "tcl_interactive" variable.
*/
is.tty = isatty(0);
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteChars(chan,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
if (TclFullFinalizationRequested()) {
/*
* Arrange for final deletion of the main interp
*/
/* ARGH Munchhausen effect */
Tcl_CreateExitHandler(FreeMainInterp, interp);
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
int argc, i;
char *av0path;
Tcl_Obj **argvObjs, *pathObj;
/*
* Set L->global->forceL if argv[0] is "L", or "-L" or "--L" was given
* as a cmd-line option. This causes Tcl_FSEvalFileEx() to wrap the
* input file in a #lang L regardless of its extension.
*/
if (L->global->tclsh_argv) {
Tcl_ListObjGetElements(interp, L->global->tclsh_argv, &argc,
&argvObjs);
pathObj = Tcl_FSGetNormalizedPath(interp, argvObjs[0]);
av0path = Tcl_GetString(pathObj);
if (av0path) {
L->global->forceL = (!strcmp(av0path+strlen(av0path)-2, "/L"));
}
for (i = 1; i < argc; ++i) {
if (!strcmp(Tcl_GetString(argvObjs[i]), "--L") ||
!strcmp(Tcl_GetString(argvObjs[i]), "-L")) {
L->global->forceL = 1;
}
}
}
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_WriteObj(chan, valuePtr);
}
Tcl_WriteChars(chan, "\n", 1);
Tcl_DecrRefCount(options);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* Process commands from stdin until there's an end-of-file. Note that we
* need to fetch the standard channels again after every eval, since they
* may have been changed.
*/
Tcl_IncrRefCount(is.commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "L", (char *) &isL, TCL_LINK_BOOLEAN);
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input == NULL) {
break;
}
}
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
length = Tcl_GetsObj(is.input, is.commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(is.input)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Check for the #lang comments and sub them out for
* meaningful commands.
*/
commandStr = Tcl_GetStringFromObj(is.commandPtr, &commandLen);
if (!isL && strncasecmp(commandStr, "#lang l", 7) == 0) {
Tcl_SetStringObj(is.commandPtr, "set ::L 1", -1);
} else if (isL && strncasecmp(commandStr, "#lang tcl", 9) == 0) {
Tcl_SetStringObj(is.commandPtr, "set('::L',0);", -1);
}
/*
* Add the newline removed by Tcl_GetsObj back to the string. Have
* to add it back before testing completeness, because it can make
* a difference. [Bug 1775878]
*/
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
Tcl_AppendToObj(is.commandPtr, "\n", 1);
if (!TclObjCommandComplete(is.commandPtr)) {
is.prompt = PROMPT_CONTINUE;
continue;
}
is.prompt = PROMPT_START;
if (isL) {
LObj = Tcl_NewStringObj("L {", -1);
Tcl_AppendObjToObj(LObj, is.commandPtr);
if (commandStr[commandLen-1] != ';') {
Tcl_AppendToObj(LObj, ";", -1);
}
Tcl_AppendToObj(LObj, "}\n", -1);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = LObj;
Tcl_IncrRefCount(is.commandPtr);
}
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
TCL_EVAL_GLOBAL);
is.input = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(is.commandPtr);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively, we
* want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
if (is.input) {
if (is.tty) {
Prompt(interp, &is);
}
Tcl_CreateChannelHandler(is.input, TCL_READABLE,
StdinProc, &is);
}
mainLoopProc();
Tcl_SetMainLoop(NULL);
if (is.input) {
Tcl_DeleteChannelHandler(is.input, StdinProc, &is);
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
}
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_SetMainLoop(NULL);
Tcl_DeleteInterp(interp);
}
#endif /* TCL_MEM_DEBUG */
}
done:
mainLoopProc = TclGetMainLoop();
if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
* this point.
*/
mainLoopProc();
Tcl_SetMainLoop(NULL);
}
if (is.commandPtr != NULL) {
Tcl_DecrRefCount(is.commandPtr);
}
/*
* Rather than calling exit, invoke the "exit" command so that users can
* replace "exit" with some other command to do additional cleanup on
* exit. The Tcl_EvalObjEx call should never return.
*/
if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is
* happening. Maybe interp has been deleted; maybe [exit] was redefined,
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
Tcl_Exit(exitCode);
}
int fbsql_fetchrow(Tcl_Interp *interp, int sql_number, int argc, char **argv) {
int i, field_type, length;
MYSQL_ROW row;
MYSQL_FIELD *field;
Tcl_Obj *obj_result;
Tcl_Obj *obj_col;
Tcl_Obj *obj_array;
Tcl_Obj *obj_element;
#if UTF_ENCODING
Tcl_DString ds;
#endif
/* check we are connected? */
if (!connection[sql_number].CONNECTED) {
Tcl_SetResult(interp, "Not connected to a server.", TCL_STATIC);
return TCL_ERROR;
}
/* check we had a query started? */
if (!connection[sql_number].query_flag) {
Tcl_SetResult(interp, "No query has been started.", TCL_STATIC);
return TCL_ERROR;
}
/* fetch some data? */
row = mysql_fetch_row(connection[sql_number].result);
if (row == NULL) {
/* if we come to the end of the data return nothing */
/* if using an array set the array elements to default/NULL values */
if (connection[sql_number].use_array) {
obj_array = Tcl_NewStringObj(connection[sql_number].array_name,strlen(connection[sql_number].array_name));
for (i = 0; i < connection[sql_number].field_count; i++) {
/* get field information */
field = mysql_fetch_field_direct(connection[sql_number].result,i);
if (field == NULL) continue;
obj_element = Tcl_NewStringObj(field->name,strlen(field->name));
/* 0 = char, 1 = numeric, 2 = datetime */
field_type = determine_field_type(field->type);
/* if the type is numeric then store 0.00 as the result */
if (field_type == 1) {
obj_col = Tcl_NewDoubleObj(0);
} else {
obj_col = Tcl_NewStringObj(NULL,0);
}
Tcl_ObjSetVar2(interp,obj_array,obj_element,obj_col,0);
/* we no longer have any use for the element object */
Tcl_DecrRefCount(obj_element);
}
/* we no longer have any use for the array object */
Tcl_DecrRefCount(obj_array);
}
return TCL_OK;
}
/* if an array name was specified on the sql command line then we */
/* transfer all results to that array - special FastBase conversions */
/* otherwise return the row as a list of columns */
if (connection[sql_number].use_array) {
obj_array = Tcl_NewStringObj(connection[sql_number].array_name,strlen(connection[sql_number].array_name));
for (i = 0; i < connection[sql_number].field_count; i++) {
/* get field information */
field = mysql_fetch_field_direct(connection[sql_number].result,i);
if (field == NULL) continue;
obj_element = Tcl_NewStringObj(field->name,strlen(field->name));
/* 0 = char, 1 = numeric, 2 = datetime */
field_type = determine_field_type(field->type);
if (row[i] == NULL) {
/* if the field is NULL and the type is numeric then store 0.00 as the result */
if (field_type == 1) {
obj_col = Tcl_NewDoubleObj(0);
} else {
obj_col = Tcl_NewStringObj(NULL,0);
}
} else {
/* if date field check for the value "0000-00-00" */
/* replace this with NULL */
if (field_type == 2 && strlen(row[i]) >= 10) {
if (strncmp(row[i],"0000-00-00",10) == 0) {
obj_col = Tcl_NewStringObj(NULL,0);
} else {
obj_col = Tcl_NewStringObj(row[i],strlen(row[i]));
}
} else {
#if UTF_ENCODING
Tcl_DStringInit(&ds);
Tcl_ExternalToUtfDString(NULL, row[i], strlen(row[i]), &ds);
obj_col = Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
#else
obj_col = Tcl_NewStringObj(row[i],strlen(row[i]));
#endif
}
}
Tcl_ObjSetVar2(interp,obj_array,obj_element,obj_col,0);
/* we no longer have any use for the element object */
Tcl_DecrRefCount(obj_element);
}
/* we no longer have any use for the array object */
Tcl_DecrRefCount(obj_array);
/* set result object pointer */
obj_result = Tcl_GetObjResult(interp);
/* return result = array name */
Tcl_SetStringObj(obj_result,connection[sql_number].array_name,strlen(connection[sql_number].array_name));
return TCL_OK;
} else {
/* set result object pointer */
obj_result = Tcl_GetObjResult(interp);
/* process all columns from query row */
for (i = 0; i < connection[sql_number].field_count; i++) {
if (row[i] == NULL) {
length = 0;
} else {
length = strlen(row[i]);
}
#if UTF_ENCODING
Tcl_DStringInit(&ds);
Tcl_ExternalToUtfDString(NULL, row[i], length, &ds);
obj_col = Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(interp, obj_result, obj_col);
Tcl_DStringFree(&ds);
#else
obj_col = Tcl_NewStringObj(row[i],length);
Tcl_ListObjAppendElement(interp,obj_result,obj_col);
#endif
}
return TCL_OK;
}
}
static int
TeststringobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar *unicode;
int varIndex, option, i, length;
#define MAX_STRINGS 11
const char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", "maxchars", "getunicode",
"appendself", "appendself2", NULL
};
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
!= TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0: /* append */
if (objc != 5) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetString(objv[3]);
Tcl_AppendToObj(varPtr[varIndex], string, length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 1: /* appendstrings */
if (objc > (MAX_STRINGS+3)) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
for (i = 3; i < objc; i++) {
strings[i-3] = Tcl_GetString(objv[i]);
}
for ( ; i < 12 + 3; i++) {
strings[i - 3] = NULL;
}
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
strings[10], strings[11]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 2: /* get */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 3: /* get2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = (int) strPtr->allocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
goto wrongNumArgs;
}
/*
* If the object currently bound to the variable with index
* varIndex has ref count 1 (i.e. the object is unshared) we can
* modify that object directly. Otherwise, if RC>1 (i.e. the
* object is shared), we must create a new object to modify/set
* and decrement the old formerly-shared object's ref count. This
* is "copy on write".
*/
string = Tcl_GetStringFromObj(objv[3], &length);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetStringObj(varPtr[varIndex], string, length);
} else {
SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 7: /* set2 */
if (objc != 4) {
goto wrongNumArgs;
}
SetVarToObj(varIndex, objv[3]);
break;
case 8: /* setlength */
if (objc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] != NULL) {
Tcl_SetObjLength(varPtr[varIndex], length);
}
break;
case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: /* getunicode */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
break;
case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 12: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
}
return TCL_OK;
}
static void
InitVars(Tcl_Interp *interp)
{
const char *machine, *os, *vers, *user;
char *tmp, *p;
char buffer[20];
Tcl_DString arch;
Tcl_Obj *path;
TnmInitPath(interp);
Tcl_SetVar2(interp, "tnm", "version", TNM_VERSION, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tnm", "url", TNM_URL, TCL_GLOBAL_ONLY);
/*
* Get the startup time of the Tnm extension.
*/
if (! tnmStartTime.sec && ! tnmStartTime.usec) {
Tcl_GetTime(&tnmStartTime);
}
sprintf(buffer, "%ld", tnmStartTime.sec);
Tcl_SetVar2(interp, "tnm", "start", buffer, TCL_GLOBAL_ONLY);
/*
* Check if the current version of the Tnm extension is still valid
* or if it has expired. Note, this is only useful in distribution
* demos or test versions. This check should be turned off on all
* stable and final releases.
*/
#ifdef TNM_EXPIRE_TIME
if (tnmStartTime.sec > TNM_EXPIRE_TIME) {
Tcl_Panic("Tnm Tcl extension expired. Please upgrade to a newer version.");
}
sprintf(buffer, "%ld", TNM_EXPIRE_TIME);
Tcl_SetVar2(interp, "tnm", "expire", buffer, TCL_GLOBAL_ONLY);
#endif
/*
* Set the host name. We are only interested in the name and not
* in a fully qualified domain name. This makes the result
* predictable and thus portable.
*/
tmp = ckstrdup(Tcl_GetHostName());
p = strchr(tmp, '.');
if (p) *p = '\0';
Tcl_SetVar2(interp, "tnm", "host", tmp, TCL_GLOBAL_ONLY);
ckfree(tmp);
/*
* Get the user name. We try a sequence of different environment
* variables in the hope to find something which works on all
* systems.
*/
user = getenv("USER");
if (user == NULL) {
user = getenv("USERNAME");
if (user == NULL) {
user = getenv("LOGNAME");
if (user == NULL) {
user = "******";
}
}
}
Tcl_SetVar2(interp, "tnm", "user", user, TCL_GLOBAL_ONLY);
/*
* Search for a directory which allows to hold temporary files.
* Save the directory name in the tnm(tmp) variable.
*/
tmp = getenv("TEMP");
if (! tmp) {
tmp = getenv("TMP");
if (! tmp) {
tmp = "/tmp";
if (access(tmp, W_OK) != 0) {
tmp = ".";
}
}
}
for (p = tmp; *p; p++) {
if (*p == '\\') {
*p = '/';
}
}
Tcl_SetVar2(interp, "tnm", "tmp", tmp, TCL_GLOBAL_ONLY);
/*
* Determine the architecture string which is used to store
* machine dependend files in the Tnm cache area.
*/
machine = Tcl_GetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
os = Tcl_GetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
vers = Tcl_GetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
Tcl_DStringInit(&arch);
if (machine && os && vers) {
Tcl_DStringAppend(&arch, machine, -1);
Tcl_DStringAppend(&arch, "-", 1);
Tcl_DStringAppend(&arch, os, -1);
Tcl_DStringAppend(&arch, "-", 1);
Tcl_DStringAppend(&arch, vers, -1);
} else {
Tcl_DStringAppend(&arch, "unknown-os", -1);
}
/*
* Initialize the tnm(cache) variable which points to a directory
* where we can cache shared data between different instantiations
* of the Tnm extension. We usually locate the cache in the users
* home directory. However, if this fails (because the user does
* not have a home), we locate the cache in the tmp file area.
*/
path = Tcl_NewObj();
Tcl_AppendStringsToObj(path, "~/.tnm", TNM_VERSION, NULL);
if (Tcl_FSConvertToPathType(interp, path) == TCL_ERROR) {
Tcl_SetStringObj(path, tmp, -1);
Tcl_AppendStringsToObj(path, "/tnm", TNM_VERSION, NULL);
}
if (Tcl_FSConvertToPathType(interp, path) == TCL_OK) {
(void) TnmMkDir(interp, path);
}
Tcl_SetVar2(interp, "tnm", "cache",
Tcl_GetStringFromObj(path, NULL), TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(path);
/*
* Remove all white spaces and slashes from the architecture string
* because these characters are a potential source of problems and
* I really do not like white spaces in a directory name.
*/
{
char *d = Tcl_DStringValue(&arch);
char *s = Tcl_DStringValue(&arch);
while (*s) {
*d = *s;
if ((!isspace((int) *s)) && (*s != '/')) d++;
s++;
}
*d = '\0';
}
Tcl_SetVar2(interp, "tnm", "arch",
Tcl_DStringValue(&arch), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&arch);
}
static void
get_register (int regnum, map_arg arg)
{
int realnum;
CORE_ADDR addr;
enum lval_type lval;
struct type *reg_vtype;
gdb_byte buffer[MAX_REGISTER_SIZE];
int optim, format;
struct cleanup *old_chain = NULL;
struct ui_file *stb;
long dummy;
char *res;
format = regformat[regnum];
if (format == 0)
format = 'x';
reg_vtype = regtype[regnum];
if (reg_vtype == NULL)
reg_vtype = register_type (get_current_arch (), regnum);
if (!target_has_registers)
{
if (result_ptr->flags & GDBTK_MAKES_LIST)
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj ("", -1));
else
Tcl_SetStringObj (result_ptr->obj_ptr, "", -1);
return;
}
frame_register (get_selected_frame (NULL), regnum, &optim, &lval,
&addr, &realnum, buffer);
if (optim)
{
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
Tcl_NewStringObj ("Optimized out", -1));
return;
}
stb = mem_fileopen ();
old_chain = make_cleanup_ui_file_delete (stb);
if (format == 'r')
{
/* shouldn't happen. raw format is deprecated */
int j;
char *ptr, buf[1024];
strcpy (buf, "0x");
ptr = buf + 2;
for (j = 0; j < register_size (get_current_arch (), regnum); j++)
{
int idx = ((gdbarch_byte_order (get_current_arch ()) == BFD_ENDIAN_BIG)
? j : register_size (get_current_arch (), regnum) - 1 - j);
sprintf (ptr, "%02x", (unsigned char) buffer[idx]);
ptr += 2;
}
fputs_unfiltered (buf, stb);
}
else
{
struct value_print_options opts;
get_formatted_print_options (&opts, format);
opts.deref_ref = 1;
opts.pretty = Val_pretty_default;
if ((TYPE_CODE (reg_vtype) == TYPE_CODE_UNION)
&& (strcmp (FIELD_NAME (TYPE_FIELD (reg_vtype, 0)),
gdbarch_register_name (get_current_arch (), regnum)) == 0))
{
val_print (FIELD_TYPE (TYPE_FIELD (reg_vtype, 0)), buffer, 0, 0,
stb, 0, NULL, &opts, current_language);
}
else
val_print (reg_vtype, buffer, 0, 0,
stb, 0, NULL, &opts, current_language);
}
res = ui_file_xstrdup (stb, &dummy);
if (result_ptr->flags & GDBTK_MAKES_LIST)
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj (res, -1));
else
Tcl_SetStringObj (result_ptr->obj_ptr, res, -1);
xfree (res);
do_cleanups (old_chain);
}
void
start_tcl(void)
{
char *id = "start_tcl";
char buf[BUFSIZ];
int fd;
int tot, len;
interp = Tcl_CreateInterp();
if (Tcl_Init(interp) == TCL_ERROR)
{
sprintf(log_buffer, "Tcl_Init error: %s",
Tcl_GetStringResult(interp));
log_err(-1, id, log_buffer);
die(0);
}
#if TCLX
#if TCL_MINOR_VERSION < 5 && TCL_MAJOR_VERSION < 8
if (TclX_Init(interp) == TCL_ERROR)
{
#else
if (Tclx_Init(interp) == TCL_ERROR)
{
#endif
sprintf(log_buffer, "Tclx_Init error: %s",
Tcl_GetStringResult(interp));
log_err(-1, id, log_buffer);
die(0);
}
#endif
add_cmds(interp);
if (initfil)
{
int code;
code = Tcl_EvalFile(interp, initfil);
if (code != TCL_OK)
{
char *trace;
trace = (char *)Tcl_GetVar(interp, "errorInfo", 0);
if (trace == NULL)
trace = (char *)Tcl_GetStringResult(interp);
fprintf(stderr, "%s: TCL error @ line %d: %s\n",
initfil, interp->errorLine, trace);
sprintf(log_buffer, "%s: TCL error @ line %d: %s",
initfil, interp->errorLine,
Tcl_GetStringResult(interp));
log_err(-1, id, log_buffer);
die(0);
}
sprintf(log_buffer, "init file %s", initfil);
log_record(PBSEVENT_SYSTEM, PBS_EVENTCLASS_SERVER,
id, log_buffer);
}
if ((fd = open(bodyfil, O_RDONLY)) == -1)
{
log_err(errno, id, bodyfil);
die(0);
}
sprintf(log_buffer, "body file: %s", bodyfil);
log_record(PBSEVENT_SYSTEM, PBS_EVENTCLASS_SERVER, id, log_buffer);
if (body)
free(body);
if ((body = malloc(BUFSIZ)) == NULL)
{
log_err(errno, id, "malloc");
die(0);
}
for (tot = 0; (len = read(fd, buf, sizeof(buf))) > 0; tot += len)
{
if ((body = realloc(body, tot + len + 1)) == NULL)
{
log_err(errno, id, "realloc");
die(0);
}
memcpy(&body[tot], buf, len);
}
if (len == -1)
{
log_err(errno, id, bodyfil);
die(0);
}
body[tot] = '\0';
close(fd);
#if TCL_MAJOR_VERSION >= 8
if (body_obj == NULL)
{
body_obj = Tcl_NewStringObj(body, tot);
Tcl_IncrRefCount(body_obj);
}
else
{
Tcl_SetStringObj(body_obj, body, tot);
}
#endif
}
int
addclient(name)
char *name;
{
static char id[] = "addclient";
struct hostent *host, *gethostbyname();
struct in_addr saddr;
if ((host = gethostbyname(name)) == NULL)
{
sprintf(log_buffer, "host %s not found", name);
log_err(-1, id, log_buffer);
return -1;
}
if (numclients >= START_CLIENTS)
{
pbs_net_t *newclients;
newclients = realloc(okclients,
sizeof(pbs_net_t) * (numclients + 1));
if (newclients == NULL)
return -1;
okclients = newclients;
}
memcpy((char *)&saddr, host->h_addr, host->h_length);
okclients[numclients++] = saddr.s_addr;
return 0;
}
/*
* read_config - read and process the configuration file (see -c option)
*
* Currently, the only statement is $clienthost to specify which systems
* can contact the scheduler.
*/
#define CONF_LINE_LEN 120
static
int
read_config(file)
char *file;
{
static char *id = "read_config";
FILE *conf;
int i;
char line[CONF_LINE_LEN];
char *token;
struct specialconfig
{
char *name;
int (*handler)();
} special[] =
{
{"clienthost", addclient },
{ NULL, NULL }
};
#if !defined(DEBUG) && !defined(NO_SECURITY_CHECK)
if (chk_file_sec(file, 0, 0, S_IWGRP | S_IWOTH, 1, 0))
return (-1);
#endif
if ((conf = fopen(file, "r")) == NULL)
{
log_err(errno, id, "cannot open config file");
return (-1);
}
while (fgets(line, CONF_LINE_LEN, conf))
{
if ((line[0] == '#') || (line[0] == '\n'))
continue; /* ignore comment & null line */
else if (line[0] == '$') /* special */
{
if ((token = strtok(line, " \t")) == NULL)
token = "";
for (i = 0; special[i].name; i++)
{
if (strcmp(token + 1, special[i].name) == 0)
break;
}
if (special[i].name == NULL)
{
sprintf(log_buffer, "config name %s not known",
token);
log_record(PBSEVENT_ERROR,
PBS_EVENTCLASS_SERVER,
msg_daemonname, log_buffer);
return (-1);
}
token = strtok(NULL, " \t");
if (*(token + strlen(token) - 1) == '\n')
*(token + strlen(token) - 1) = '\0';
if (special[i].handler(token))
{
fclose(conf);
return (-1);
}
}
else
{
log_record(PBSEVENT_ERROR, PBS_EVENTCLASS_SERVER,
msg_daemonname,
"invalid line in config file");
fclose(conf);
return (-1);
}
}
fclose(conf);
return (0);
}
void
restart(sig)
int sig;
{
char *id = "restart";
if (sig)
{
sprintf(log_buffer, "restart on signal %d", sig);
log_close(1);
log_open(logfile, path_log);
}
else
{
sprintf(log_buffer, "restart command");
}
log_record(PBSEVENT_SYSTEM, PBS_EVENTCLASS_SERVER, id, log_buffer);
Tcl_DeleteInterp(interp);
if (configfile)
{
if (read_config(configfile) != 0)
die(0);
}
start_tcl();
}
void
badconn(msg)
char *msg;
{
static char id[] = "badconn";
struct in_addr addr;
char buf[5*sizeof(addr) + 100];
struct hostent *phe;
addr = saddr.sin_addr;
phe = gethostbyaddr((void *) & addr, sizeof(addr), AF_INET);
if (phe == NULL)
{
char hold[6];
int i;
union
{
struct in_addr aa;
u_char bb[sizeof(addr)];
} uu;
uu.aa = addr;
sprintf(buf, "%u", uu.bb[0]);
for (i = 1; i < (int)sizeof(addr); i++)
{
sprintf(hold, ".%u", uu.bb[i]);
strcat(buf, hold);
}
}
else
{
strncpy(buf, phe->h_name, sizeof(buf));
buf[sizeof(buf)-1] = '\0';
}
sprintf(log_buffer, "%s on port %u %s", buf, ntohs(saddr.sin_port), msg);
log_err(-1, id, log_buffer);
return;
}
unsigned int
server_command()
{
static char id[] = "server_command";
int new_socket;
int i;
torque_socklen_t slen;
unsigned int cmd;
pbs_net_t addr;
slen = sizeof(saddr);
new_socket = accept(server_sock,
(struct sockaddr *) & saddr, &slen);
if (new_socket == -1)
{
log_err(errno, id, "accept");
return SCH_ERROR;
}
if (ntohs(saddr.sin_port) >= IPPORT_RESERVED)
{
badconn("non-reserved port");
close(new_socket);
return SCH_ERROR;
}
addr = (pbs_net_t)saddr.sin_addr.s_addr;
for (i = 0; i < numclients; i++)
{
if (addr == okclients[i])
break;
}
if (i == numclients)
{
badconn("unauthorized host");
close(new_socket);
return SCH_ERROR;
}
if ((connector = socket_to_conn(new_socket)) < 0)
{
log_err(errno, id, "socket_to_conn");
return SCH_ERROR;
}
if (get_4byte(new_socket, &cmd) != 1)
{
log_err(errno, id, "get4bytes");
return SCH_ERROR;
}
return cmd;
}
/*
* lock_out - lock out other daemons from this directory.
*/
static void lock_out(fds, op)
int fds;
int op; /* F_WRLCK or F_UNLCK */
{
struct flock flock;
flock.l_type = op;
flock.l_whence = SEEK_SET;
flock.l_start = 0;
flock.l_len = 0; /* whole file */
if (fcntl(fds, F_SETLK, &flock) < 0)
{
(void)strcpy(log_buffer, "pbs_sched: another scheduler running\n");
log_err(errno, msg_daemonname, log_buffer);
fprintf(stderr, log_buffer);
exit(1);
}
}
int main(argc, argv)
int argc;
char *argv[];
{
char *id = "main";
int code;
struct hostent *hp;
int go, c, errflg = 0;
int lockfds;
int t = 1;
char *ptr;
pid_t pid;
char *cp, host[100];
char *homedir = PBS_SERVER_HOME;
unsigned int port;
char path_priv[_POSIX_PATH_MAX];
char *dbfile = "sched_out";
int alarm_time = 180;
struct sigaction act;
caddr_t curr_brk = 0, next_brk;
extern char *optarg;
extern int optind, opterr;
fd_set fdset;
#ifndef DEBUG
if (IamRoot() == 0)
{
return (1);
}
#endif /* DEBUG */
glob_argv = argv;
if ((cp = strrchr(argv[0], '/')) == NULL)
cp = argv[0];
else
cp++;
msg_daemonname = strdup(cp);
port = get_svrport(PBS_SCHEDULER_SERVICE_NAME, "tcp",
PBS_SCHEDULER_SERVICE_PORT);
while ((c = getopt(argc, argv, "L:S:d:i:b:t:p:a:vc:")) != EOF)
{
switch (c)
{
case 'L':
logfile = optarg;
break;
case 'S':
port = (unsigned int)atoi(optarg);
if (port == 0)
{
fprintf(stderr,
"%s: illegal port\n", optarg);
errflg = 1;
}
break;
case 'd':
homedir = optarg;
break;
case 'i': /* initialize */
initfil = optarg;
break;
case 'b':
bodyfil = optarg;
break;
case 't':
termfil = optarg;
break;
case 'p':
dbfile = optarg;
break;
case 'a':
alarm_time = strtol(optarg, &ptr, 10);
if (alarm_time <= 0 || *ptr != '\0')
{
fprintf(stderr,
"%s: bad alarm time\n", optarg);
errflg = 1;
}
break;
case 'c':
configfile = optarg;
break;
case 'v':
verbose = 1;
break;
case '?':
errflg = 1;
break;
}
}
if (errflg || optind != argc)
{
static char *options[] =
{
"[-L logfile]",
"[-S port]",
"[-d home]",
"[-i init]",
"[-b body]",
"[-t term]",
"[-p output]",
"[-a alarm]",
"[-c configfile]",
"[-v]",
NULL
};
int i;
fprintf(stderr, "usage: %s\n", argv[0]);
for (i = 0; options[i]; i++)
fprintf(stderr, "\t%s\n", options[i]);
exit(1);
}
/* Save the original working directory for "restart" */
if ((oldpath = getcwd((char *)NULL, MAXPATHLEN)) == NULL)
{
fprintf(stderr, "cannot get current working directory\n");
exit(1);
}
(void)sprintf(path_priv, "%s/sched_priv", homedir);
#if !defined(DEBUG) && !defined(NO_SECURITY_CHECK)
c = chk_file_sec(path_priv, 1, 0, S_IWGRP | S_IWOTH, 1, 0);
c |= chk_file_sec(PBS_ENVIRON, 0, 0, S_IWGRP | S_IWOTH, 0, 0);
if (c != 0) exit(1);
#endif /* not DEBUG and not NO_SECURITY_CHECK */
if (chdir(path_priv) == -1)
{
perror(path_priv);
exit(1);
}
(void)sprintf(path_log, "%s/sched_logs", homedir);
(void)strcpy(pbs_current_user, "Scheduler");
/* The following is code to reduce security risks */
/* start out with standard umask, system resource limit infinite */
umask(022);
if (setup_env(PBS_ENVIRON) == -1)
exit(1);
c = getgid();
(void)setgroups(1, (gid_t *)&c); /* secure suppl. group ids */
c = sysconf(_SC_OPEN_MAX);
while (--c > 2)
(void)close(c); /* close any file desc left open by parent */
#ifndef DEBUG
#ifdef _CRAY
(void)limit(C_JOB, 0, L_CPROC, 0);
(void)limit(C_JOB, 0, L_CPU, 0);
(void)limit(C_JOBPROCS, 0, L_CPU, 0);
(void)limit(C_PROC, 0, L_FD, 255);
(void)limit(C_JOB, 0, L_FSBLK, 0);
(void)limit(C_JOBPROCS, 0, L_FSBLK, 0);
(void)limit(C_JOB, 0, L_MEM , 0);
(void)limit(C_JOBPROCS, 0, L_MEM , 0);
#else /* not _CRAY */
{
struct rlimit rlimit;
rlimit.rlim_cur = RLIM_INFINITY;
rlimit.rlim_max = RLIM_INFINITY;
(void)setrlimit(RLIMIT_CPU, &rlimit);
(void)setrlimit(RLIMIT_FSIZE, &rlimit);
(void)setrlimit(RLIMIT_DATA, &rlimit);
(void)setrlimit(RLIMIT_STACK, &rlimit);
#ifdef RLIMIT_RSS
(void)setrlimit(RLIMIT_RSS , &rlimit);
#endif /* RLIMIT_RSS */
#ifdef RLIMIT_VMEM
(void)setrlimit(RLIMIT_VMEM , &rlimit);
#endif /* RLIMIT_VMEM */
}
#endif /* not _CRAY */
#if !defined(NO_SECURITY_CHECK)
c = 0;
if (initfil)
{
if (*initfil != '/')
{
(void)sprintf(log_buffer, "%s/%s", path_priv, initfil);
c |= chk_file_sec(log_buffer, 0, 0, S_IWGRP | S_IWOTH, 1, 0);
}
else
{
c |= chk_file_sec(initfil, 0, 0, S_IWGRP | S_IWOTH, 1, 0);
}
}
if (bodyfil)
{
if (*bodyfil != '/')
{
(void)sprintf(log_buffer, "%s/%s", path_priv, bodyfil);
c |= chk_file_sec(log_buffer, 0, 0, S_IWGRP | S_IWOTH, 1, 0);
}
else
{
c |= chk_file_sec(bodyfil, 0, 0, S_IWGRP | S_IWOTH, 1, 0);
}
}
if (termfil)
{
if (*termfil != '/')
{
(void)sprintf(log_buffer, "%s/%s", path_priv, termfil);
c |= chk_file_sec(log_buffer, 0, 0, S_IWGRP | S_IWOTH, 1, 0);
}
else
{
c |= chk_file_sec(termfil, 0, 0, S_IWGRP | S_IWOTH, 1, 0);
}
}
if (c) exit(1);
#endif /* not NO_SECURITY_CHECK */
#endif /* not DEBUG */
if (log_open(logfile, path_log) == -1)
{
fprintf(stderr, "%s: logfile could not be opened\n", argv[0]);
exit(1);
}
if (gethostname(host, sizeof(host)) == -1)
{
char *prob = "gethostname";
log_err(errno, id, prob);
perror(prob);
die(0);
}
if ((hp = gethostbyname(host)) == NULL)
{
char *prob = "gethostbyname";
log_err(errno, id, prob);
perror(prob);
die(0);
}
if ((server_sock = socket(AF_INET, SOCK_STREAM, 0)) < 0)
{
char *prob = "socket";
log_err(errno, id, prob);
perror(prob);
die(0);
}
if (setsockopt(server_sock, SOL_SOCKET, SO_REUSEADDR,
(char *)&t, sizeof(t)) == -1)
{
char *prob = "setsockopt";
log_err(errno, id, prob);
perror(prob);
die(0);
}
saddr.sin_family = AF_INET;
saddr.sin_port = htons((unsigned short)port);
memcpy(&saddr.sin_addr, hp->h_addr, hp->h_length);
if (bind(server_sock, (struct sockaddr *)&saddr, sizeof(saddr)) < 0)
{
char *prob = "bind";
log_err(errno, id, prob);
perror(prob);
die(0);
}
if (listen(server_sock, 5) < 0)
{
char *prob = "listen";
log_err(errno, id, prob);
perror(prob);
die(0);
}
okclients = (pbs_net_t *)calloc(START_CLIENTS, sizeof(pbs_net_t));
addclient("localhost"); /* who has permission to call MOM */
addclient(host);
if (configfile)
{
if (read_config(configfile) != 0)
die(0);
}
lockfds = open("sched.lock", O_CREAT | O_TRUNC | O_WRONLY, 0644);
if (lockfds < 0)
{
char *prob = "lock file";
log_err(errno, id, prob);
perror(prob);
die(0);
}
lock_out(lockfds, F_WRLCK);
#ifndef DEBUG
lock_out(lockfds, F_UNLCK);
if ((pid = fork()) == -1) /* error on fork */
{
char *prob = "fork";
log_err(errno, id, prob);
perror(prob);
die(0);
}
else if (pid > 0) /* parent exits */
exit(0);
if ((pid = setsid()) == -1)
{
log_err(errno, id, "setsid");
die(0);
}
lock_out(lockfds, F_WRLCK);
freopen(dbfile, "a", stdout);
setvbuf(stdout, NULL, _IOLBF, 0);
dup2(fileno(stdout), fileno(stderr));
#else
pid = getpid();
setvbuf(stdout, NULL, _IOLBF, 0);
setvbuf(stderr, NULL, _IOLBF, 0);
#endif
freopen("/dev/null", "r", stdin);
/* write schedulers pid into lockfile */
(void)sprintf(log_buffer, "%d\n", pid);
(void)write(lockfds, log_buffer, strlen(log_buffer) + 1);
#if (PLOCK_DAEMONS & 2)
(void)plock(PROCLOCK); /* lock daemon into memory */
#endif
sprintf(log_buffer, "%s startup pid %d", argv[0], pid);
log_record(PBSEVENT_SYSTEM, PBS_EVENTCLASS_SERVER, id, log_buffer);
sprintf(log_buffer, "%s using TCL %s (%s)", argv[0],
TCL_VERSION, TCL_PATCH_LEVEL);
fprintf(stderr, "%s\n", log_buffer);
log_record(PBSEVENT_SYSTEM, PBS_EVENTCLASS_SERVER, id, log_buffer);
fullresp(0);
sigemptyset(&allsigs);
act.sa_flags = 0;
sigaddset(&allsigs, SIGHUP); /* remember to block these */
sigaddset(&allsigs, SIGINT); /* during critical sections */
sigaddset(&allsigs, SIGTERM); /* so we don't get confused */
act.sa_mask = allsigs;
act.sa_handler = restart; /* do a restart on SIGHUP */
sigaction(SIGHUP, &act, NULL);
act.sa_handler = toolong; /* handle an alarm call */
sigaction(SIGALRM, &act, NULL);
act.sa_handler = die; /* bite the biscuit for all following */
sigaction(SIGINT, &act, NULL);
sigaction(SIGTERM, &act, NULL);
start_tcl();
FD_ZERO(&fdset);
for (go = 1; go;)
{
unsigned int cmd;
FD_SET(server_sock, &fdset);
if (select(FD_SETSIZE, &fdset, NULL, NULL, NULL) == -1)
{
if (errno != EINTR)
log_err(errno, id, "select");
continue;
}
if (!FD_ISSET(server_sock, &fdset))
continue;
cmd = server_command();
if (cmd == (unsigned)SCH_ERROR || cmd == (unsigned)SCH_SCHEDULE_NULL)
continue;
if (sigprocmask(SIG_BLOCK, &allsigs, &oldsigs) == -1)
log_err(errno, id, "sigprocmaskSIG_BLOCK)");
if (verbose)
{
sprintf(log_buffer, "command %d", cmd);
log_record(PBSEVENT_SYSTEM, PBS_EVENTCLASS_SERVER,
id, log_buffer);
}
switch (cmd)
{
case SCH_SCHEDULE_NEW:
case SCH_SCHEDULE_TERM:
case SCH_SCHEDULE_TIME:
case SCH_SCHEDULE_RECYC:
case SCH_SCHEDULE_CMD:
case SCH_SCHEDULE_FIRST:
alarm(alarm_time);
#if TCL_MAJOR_VERSION >= 8
/* execute compiled body code for TCL-8 */
code = Tcl_EvalObj(interp, body_obj);
#else
code = Tcl_Eval(interp, body);
#endif
alarm(0);
switch (code)
{
case TCL_OK:
case TCL_RETURN:
break;
default:
{
char *trace;
char codename[20];
switch (code)
{
case TCL_BREAK:
strcpy(codename, "break");
break;
case TCL_CONTINUE:
strcpy(codename, "continue");
break;
default:
strcpy(codename, "<unknown>");
break;
}
trace = (char *)Tcl_GetVar(interp, "errorInfo", 0);
if (trace == NULL)
trace = (char *)Tcl_GetStringResult(interp);
fprintf(stderr, "%s: TCL interpreter return code %d (%s) @ line %d: %s\n",
bodyfil, code, codename,
interp->errorLine, trace);
sprintf(log_buffer,
"%s: TCL error @ line %d: %s",
bodyfil, interp->errorLine,
Tcl_GetStringResult(interp));
log_err(-1, id, log_buffer);
die(0);
}
}
break;
case SCH_CONFIGURE:
case SCH_RULESET:
restart(0);
break;
case SCH_QUIT:
go = 0;
break;
default:
log_err(-1, id, "unknown command");
break;
}
if (connector >= 0 && server_disconnect(connector))
{
log_err(errno, id, "server_disconnect");
die(0);
}
connector = -1;
if (verbose)
{
next_brk = (caddr_t)sbrk(0);
if (next_brk > curr_brk)
{
sprintf(log_buffer, "brk point %p", next_brk);
log_record(PBSEVENT_SYSTEM,
PBS_EVENTCLASS_SERVER,
id, log_buffer);
curr_brk = next_brk;
}
}
if (sigprocmask(SIG_SETMASK, &oldsigs, NULL) == -1)
log_err(errno, id, "sigprocmask(SIG_SETMASK)");
}
if (termfil)
{
code = Tcl_EvalFile(interp, termfil);
if (code != TCL_OK)
{
char *trace;
trace = (char *)Tcl_GetVar(interp, "errorInfo", 0);
if (trace == NULL)
trace = (char *)Tcl_GetStringResult(interp);
fprintf(stderr, "%s: TCL error @ line %d: %s\n",
termfil, interp->errorLine, trace);
sprintf(log_buffer, "%s: TCL error @ line %d: %s",
termfil, interp->errorLine,
Tcl_GetStringResult(interp));
log_err(-1, id, log_buffer);
die(0);
}
sprintf(log_buffer, "term file: %s", termfil);
log_record(PBSEVENT_SYSTEM, PBS_EVENTCLASS_SERVER,
id, log_buffer);
}
sprintf(log_buffer, "%s normal finish pid %d", argv[0], pid);
log_record(PBSEVENT_SYSTEM, PBS_EVENTCLASS_SERVER, id, log_buffer);
(void)close(server_sock);
exit(0);
}
