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

00001 /*
00002  * pkgc.c --
00003  *
00004  *      This file contains a simple Tcl package "pkgc" that is intended for
00005  *      testing the Tcl dynamic loading facilities. It can be used in both
00006  *      safe and unsafe interpreters.
00007  *
00008  * Copyright (c) 1995 Sun Microsystems, Inc.
00009  *
00010  * See the file "license.terms" for information on usage and redistribution of
00011  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
00012  *
00013  * RCS: @(#) $Id: pkgc.c,v 1.9 2007/12/13 15:28:43 dgp Exp $
00014  */
00015 
00016 #include "tcl.h"
00017 
00018 /*
00019  * Prototypes for procedures defined later in this file:
00020  */
00021 
00022 static int    Pkgc_SubObjCmd(ClientData clientData,
00023                 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
00024 static int    Pkgc_UnsafeObjCmd(ClientData clientData,
00025                 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
00026 
00027 /*
00028  *----------------------------------------------------------------------
00029  *
00030  * Pkgc_SubObjCmd --
00031  *
00032  *      This procedure is invoked to process the "pkgc_sub" Tcl command. It
00033  *      expects two arguments and returns their difference.
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 Pkgc_SubObjCmd(
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 first, second;
00052 
00053     if (objc != 3) {
00054         Tcl_WrongNumArgs(interp, 1, objv, "num num");
00055         return TCL_ERROR;
00056     }
00057     if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
00058             || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
00059         return TCL_ERROR;
00060     }
00061     Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
00062     return TCL_OK;
00063 }
00064 
00065 /*
00066  *----------------------------------------------------------------------
00067  *
00068  * Pkgc_UnsafeCmd --
00069  *
00070  *      This procedure is invoked to process the "pkgc_unsafe" Tcl command. It
00071  *      just returns a constant string.
00072  *
00073  * Results:
00074  *      A standard Tcl result.
00075  *
00076  * Side effects:
00077  *      See the user documentation.
00078  *
00079  *----------------------------------------------------------------------
00080  */
00081 
00082 static int
00083 Pkgc_UnsafeObjCmd(
00084     ClientData dummy,           /* Not used. */
00085     Tcl_Interp *interp,         /* Current interpreter. */
00086     int objc,                   /* Number of arguments. */
00087     Tcl_Obj *CONST objv[])      /* Argument objects. */
00088 {
00089     Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1));
00090     return TCL_OK;
00091 }
00092 
00093 /*
00094  *----------------------------------------------------------------------
00095  *
00096  * Pkgc_Init --
00097  *
00098  *      This is a package initialization procedure, which is called by Tcl
00099  *      when this package is to be added to an interpreter.
00100  *
00101  * Results:
00102  *      None.
00103  *
00104  * Side effects:
00105  *      None.
00106  *
00107  *----------------------------------------------------------------------
00108  */
00109 
00110 int
00111 Pkgc_Init(
00112     Tcl_Interp *interp)         /* Interpreter in which the package is to be
00113                                  * made available. */
00114 {
00115     int code;
00116 
00117     if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
00118         return TCL_ERROR;
00119     }
00120     code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2");
00121     if (code != TCL_OK) {
00122         return code;
00123     }
00124     Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd,
00125             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
00126     Tcl_CreateObjCommand(interp, "pkgc_unsafe", Pkgc_UnsafeObjCmd,
00127             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
00128     return TCL_OK;
00129 }
00130 
00131 /*
00132  *----------------------------------------------------------------------
00133  *
00134  * Pkgc_SafeInit --
00135  *
00136  *      This is a package initialization procedure, which is called by Tcl
00137  *      when this package is to be added to a safe interpreter.
00138  *
00139  * Results:
00140  *      None.
00141  *
00142  * Side effects:
00143  *      None.
00144  *
00145  *----------------------------------------------------------------------
00146  */
00147 
00148 int
00149 Pkgc_SafeInit(
00150     Tcl_Interp *interp)         /* Interpreter in which the package is to be
00151                                  * made available. */
00152 {
00153     int code;
00154 
00155     if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
00156         return TCL_ERROR;
00157     }
00158     code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2");
00159     if (code != TCL_OK) {
00160         return code;
00161     }
00162     Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, (ClientData) 0,
00163             (Tcl_CmdDeleteProc *) NULL);
00164     return TCL_OK;
00165 }