util/src/TclTk/tcl8.6.12/unix/dltest/pkgd.c

   1 /*
   2  * pkgd.c --
   3  *
   4  *      This file contains a simple Tcl package "pkgd" that is intended for
   5  *      testing the Tcl dynamic loading facilities. It can be used in both
   6  *      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 of
  11  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12  */
  13
  14 #undef STATIC_BUILD
  15 #include "tcl.h"
  16
  17 /*
  18  * Prototypes for procedures defined later in this file:
  19  */
  20
  21 static int    Pkgd_SubObjCmd(ClientData clientData,
  22                 Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
  23 static int    Pkgd_UnsafeObjCmd(ClientData clientData,
  24                 Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
  25 \f
  26 /*
  27  *----------------------------------------------------------------------
  28  *
  29  * Pkgd_SubObjCmd --
  30  *
  31  *      This procedure is invoked to process the "pkgd_sub" Tcl command. It
  32  *      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
  43 static int
  44 Pkgd_SubObjCmd(
  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     (void)dummy;
  52
  53     if (objc != 3) {
  54         Tcl_WrongNumArgs(interp, 1, objv, "num num");
  55         return TCL_ERROR;
  56     }
  57     if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
  58             || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
  59         return TCL_ERROR;
  60     }
  61     Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
  62     return TCL_OK;
  63 }
  64 \f
  65 /*
  66  *----------------------------------------------------------------------
  67  *
  68  * Pkgd_UnsafeCmd --
  69  *
  70  *      This procedure is invoked to process the "pkgd_unsafe" Tcl command. It
  71  *      just returns a constant string.
  72  *
  73  * Results:
  74  *      A standard Tcl result.
  75  *
  76  * Side effects:
  77  *      See the user documentation.
  78  *
  79  *----------------------------------------------------------------------
  80  */
  81
  82 static int
  83 Pkgd_UnsafeObjCmd(
  84     ClientData dummy,           /* Not used. */
  85     Tcl_Interp *interp,         /* Current interpreter. */
  86     int objc,                   /* Number of arguments. */
  87     Tcl_Obj *const objv[])      /* Argument objects. */
  88 {
  89     (void)dummy;
  90     (void)objc;
  91     (void)objv;
  92
  93     Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1));
  94     return TCL_OK;
  95 }
  96 \f
  97 /*
  98  *----------------------------------------------------------------------
  99  *
 100  * Pkgd_Init --
 101  *
 102  *      This is a package initialization procedure, which is called by Tcl
 103  *      when this package is to be added to an interpreter.
 104  *
 105  * Results:
 106  *      None.
 107  *
 108  * Side effects:
 109  *      None.
 110  *
 111  *----------------------------------------------------------------------
 112  */
 113
 114 DLLEXPORT int
 115 Pkgd_Init(
 116     Tcl_Interp *interp)         /* Interpreter in which the package is to be
 117                                  * made available. */
 118 {
 119     int code;
 120
 121     if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
 122         return TCL_ERROR;
 123     }
 124     code = Tcl_PkgProvide(interp, "pkgd", "7.3");
 125     if (code != TCL_OK) {
 126         return code;
 127     }
 128     Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, NULL, NULL);
 129     Tcl_CreateObjCommand(interp, "pkgd_unsafe", Pkgd_UnsafeObjCmd, NULL,
 130             NULL);
 131     return TCL_OK;
 132 }
 133 \f
 134 /*
 135  *----------------------------------------------------------------------
 136  *
 137  * Pkgd_SafeInit --
 138  *
 139  *      This is a package initialization procedure, which is called by Tcl
 140  *      when this package is to be added to a safe interpreter.
 141  *
 142  * Results:
 143  *      None.
 144  *
 145  * Side effects:
 146  *      None.
 147  *
 148  *----------------------------------------------------------------------
 149  */
 150
 151 DLLEXPORT int
 152 Pkgd_SafeInit(
 153     Tcl_Interp *interp)         /* Interpreter in which the package is to be
 154                                  * made available. */
 155 {
 156     int code;
 157
 158     if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
 159         return TCL_ERROR;
 160     }
 161     code = Tcl_PkgProvide(interp, "pkgd", "7.3");
 162     if (code != TCL_OK) {
 163         return code;
 164     }
 165     Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, NULL, NULL);
 166     return TCL_OK;
 167 }