1/* 2 * pkgc.c -- 3 * 4 * This file contains a simple Tcl package "pkgc" that is intended 5 * for testing the Tcl dynamic loading facilities. It can be used 6 * in both safe and unsafe interpreters. 7 * 8 * Copyright (c) 1995 Sun Microsystems, Inc. 9 * 10 * See the file "license.terms" for information on usage and redistribution 11 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 * 13 * RCS: @(#) $Id: pkgc.c,v 1.4 2000/04/04 08:06:07 hobbs Exp $ 14 */ 15#include "tcl.h" 16 17/* 18 * Prototypes for procedures defined later in this file: 19 */ 20 21static int Pkgc_SubObjCmd _ANSI_ARGS_((ClientData clientData, 22 Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); 23static int Pkgc_UnsafeObjCmd _ANSI_ARGS_((ClientData clientData, 24 Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); 25 26/* 27 *---------------------------------------------------------------------- 28 * 29 * Pkgc_SubObjCmd -- 30 * 31 * This procedure is invoked to process the "pkgc_sub" Tcl command. 32 * It expects two arguments and returns their difference. 33 * 34 * Results: 35 * A standard Tcl result. 36 * 37 * Side effects: 38 * See the user documentation. 39 * 40 *---------------------------------------------------------------------- 41 */ 42 43static int 44Pkgc_SubObjCmd(dummy, interp, objc, objv) 45 ClientData dummy; /* Not used. */ 46 Tcl_Interp *interp; /* Current interpreter. */ 47 int objc; /* Number of arguments. */ 48 Tcl_Obj * CONST objv[]; /* Argument objects. */ 49{ 50 int first, second; 51 52 if (objc != 3) { 53 Tcl_WrongNumArgs(interp, 1, objv, "num num"); 54 return TCL_ERROR; 55 } 56 if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK) 57 || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) { 58 return TCL_ERROR; 59 } 60 Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second)); 61 return TCL_OK; 62} 63 64/* 65 *---------------------------------------------------------------------- 66 * 67 * Pkgc_UnsafeCmd -- 68 * 69 * This procedure is invoked to process the "pkgc_unsafe" Tcl command. 70 * It just returns a constant string. 71 * 72 * Results: 73 * A standard Tcl result. 74 * 75 * Side effects: 76 * See the user documentation. 77 * 78 *---------------------------------------------------------------------- 79 */ 80 81static int 82Pkgc_UnsafeObjCmd(dummy, interp, objc, objv) 83 ClientData dummy; /* Not used. */ 84 Tcl_Interp *interp; /* Current interpreter. */ 85 int objc; /* Number of arguments. */ 86 Tcl_Obj * CONST objv[]; /* Argument objects. */ 87{ 88 Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); 89 return TCL_OK; 90} 91 92/* 93 *---------------------------------------------------------------------- 94 * 95 * Pkgc_Init -- 96 * 97 * This is a package initialization procedure, which is called 98 * by Tcl when this package is to be added to an interpreter. 99 * 100 * Results: 101 * None. 102 * 103 * Side effects: 104 * None. 105 * 106 *---------------------------------------------------------------------- 107 */ 108 109int 110Pkgc_Init(interp) 111 Tcl_Interp *interp; /* Interpreter in which the package is 112 * to be made available. */ 113{ 114 int code; 115 116 if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { 117 return TCL_ERROR; 118 } 119 code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); 120 if (code != TCL_OK) { 121 return code; 122 } 123 Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, 124 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 125 Tcl_CreateObjCommand(interp, "pkgc_unsafe", Pkgc_UnsafeObjCmd, 126 (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); 127 return TCL_OK; 128} 129 130/* 131 *---------------------------------------------------------------------- 132 * 133 * Pkgc_SafeInit -- 134 * 135 * This is a package initialization procedure, which is called 136 * by Tcl when this package is to be added to an unsafe interpreter. 137 * 138 * Results: 139 * None. 140 * 141 * Side effects: 142 * None. 143 * 144 *---------------------------------------------------------------------- 145 */ 146 147int 148Pkgc_SafeInit(interp) 149 Tcl_Interp *interp; /* Interpreter in which the package is 150 * to be made available. */ 151{ 152 int code; 153 154 if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) { 155 return TCL_ERROR; 156 } 157 code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); 158 if (code != TCL_OK) { 159 return code; 160 } 161 Tcl_CreateObjCommand(interp, "pkgc_sub", Pkgc_SubObjCmd, (ClientData) 0, 162 (Tcl_CmdDeleteProc *) NULL); 163 return TCL_OK; 164} 165