/home/ntakagi/work/tcl8.5.1/unix/dltest/pkga.c Source File

00001 /*
00002  * pkga.c --
00003  *
00004  *      This file contains a simple Tcl package "pkga" that is intended for
00005  *      testing the Tcl dynamic loading facilities.
00006  *
00007  * Copyright (c) 1995 Sun Microsystems, Inc.
00008  *
00009  * See the file "license.terms" for information on usage and redistribution of
00010  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
00011  *
00012  * RCS: @(#) $Id: pkga.c,v 1.12 2007/12/13 15:28:42 dgp Exp $
00013  */
00014 
00015 #include "tcl.h"
00016 
00017 /*
00018  * Prototypes for procedures defined later in this file:
00019  */
00020 
00021 static int    Pkga_EqObjCmd(ClientData clientData,
00022                 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
00023 static int    Pkga_QuoteObjCmd(ClientData clientData,
00024                 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
00025 
00026 /*
00027  *----------------------------------------------------------------------
00028  *
00029  * Pkga_EqObjCmd --
00030  *
00031  *      This procedure is invoked to process the "pkga_eq" Tcl command. It
00032  *      expects two arguments and returns 1 if they are the same, 0 if they
00033  *      are different.
00034  *
00035  * Results:
00036  *      A standard Tcl result.
00037  *
00038  * Side effects:
00039  *      See the user documentation.
00040  *
00041  *----------------------------------------------------------------------
00042  */
00043 
00044 static int
00045 Pkga_EqObjCmd(
00046     ClientData dummy,           /* Not used. */
00047     Tcl_Interp *interp,         /* Current interpreter. */
00048     int objc,                   /* Number of arguments. */
00049     Tcl_Obj *CONST objv[])      /* Argument objects. */
00050 {
00051     int result;
00052     CONST char *str1, *str2;
00053     int len1, len2;
00054 
00055     if (objc != 3) {
00056         Tcl_WrongNumArgs(interp, 1, objv,  "string1 string2");
00057         return TCL_ERROR;
00058     }
00059 
00060     str1 = Tcl_GetStringFromObj(objv[1], &len1);
00061     str2 = Tcl_GetStringFromObj(objv[2], &len2);
00062     if (len1 == len2) {
00063         result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
00064     } else {
00065         result = 0;
00066     }
00067     Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
00068     return TCL_OK;
00069 }
00070 
00071 /*
00072  *----------------------------------------------------------------------
00073  *
00074  * Pkga_QuoteObjCmd --
00075  *
00076  *      This procedure is invoked to process the "pkga_quote" Tcl command. It
00077  *      expects one argument, which it returns as result.
00078  *
00079  * Results:
00080  *      A standard Tcl result.
00081  *
00082  * Side effects:
00083  *      See the user documentation.
00084  *
00085  *----------------------------------------------------------------------
00086  */
00087 
00088 static int
00089 Pkga_QuoteObjCmd(
00090     ClientData dummy,           /* Not used. */
00091     Tcl_Interp *interp,         /* Current interpreter. */
00092     int objc,                   /* Number of arguments. */
00093     Tcl_Obj *CONST objv[])      /* Argument strings. */
00094 {
00095     if (objc != 2) {
00096         Tcl_WrongNumArgs(interp, 1, objv, "value");
00097         return TCL_ERROR;
00098     }
00099     Tcl_SetObjResult(interp, objv[1]);
00100     return TCL_OK;
00101 }
00102 
00103 /*
00104  *----------------------------------------------------------------------
00105  *
00106  * Pkga_Init --
00107  *
00108  *      This is a package initialization procedure, which is called by Tcl
00109  *      when this package is to be added to an interpreter.
00110  *
00111  * Results:
00112  *      None.
00113  *
00114  * Side effects:
00115  *      None.
00116  *
00117  *----------------------------------------------------------------------
00118  */
00119 
00120 int
00121 Pkga_Init(
00122     Tcl_Interp *interp)         /* Interpreter in which the package is to be
00123                                  * made available. */
00124 {
00125     int code;
00126 
00127     if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
00128         return TCL_ERROR;
00129     }
00130     code = Tcl_PkgProvide(interp, "Pkga", "1.0");
00131     if (code != TCL_OK) {
00132         return code;
00133     }
00134     Tcl_CreateObjCommand(interp, "pkga_eq", Pkga_EqObjCmd,
00135             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
00136     Tcl_CreateObjCommand(interp, "pkga_quote", Pkga_QuoteObjCmd,
00137             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
00138     return TCL_OK;
00139 }