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

   1 /*
   2  * pkga.c --
   3  *
   4  *      This file contains a simple Tcl package "pkga" that is intended for
   5  *      testing the Tcl dynamic loading facilities.
   6  *
   7  * Copyright (c) 1995 Sun Microsystems, Inc.
   8  *
   9  * See the file "license.terms" for information on usage and redistribution of
  10  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11  */
  12
  13 #undef STATIC_BUILD
  14 #include "tcl.h"
  15
  16 /*
  17  * Prototypes for procedures defined later in this file:
  18  */
  19
  20 static int    Pkga_EqObjCmd(ClientData clientData,
  21                 Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
  22 static int    Pkga_QuoteObjCmd(ClientData clientData,
  23                 Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
  24 \f
  25 /*
  26  *----------------------------------------------------------------------
  27  *
  28  * Pkga_EqObjCmd --
  29  *
  30  *      This procedure is invoked to process the "pkga_eq" Tcl command. It
  31  *      expects two arguments and returns 1 if they are the same, 0 if they
  32  *      are different.
  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 Pkga_EqObjCmd(
  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 result;
  51     const char *str1, *str2;
  52     int len1, len2;
  53     (void)dummy;
  54
  55     if (objc != 3) {
  56         Tcl_WrongNumArgs(interp, 1, objv,  "string1 string2");
  57         return TCL_ERROR;
  58     }
  59
  60     str1 = Tcl_GetStringFromObj(objv[1], &len1);
  61     str2 = Tcl_GetStringFromObj(objv[2], &len2);
  62     if (len1 == len2) {
  63         result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
  64     } else {
  65         result = 0;
  66     }
  67     Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
  68     return TCL_OK;
  69 }
  70 \f
  71 /*
  72  *----------------------------------------------------------------------
  73  *
  74  * Pkga_QuoteObjCmd --
  75  *
  76  *      This procedure is invoked to process the "pkga_quote" Tcl command. It
  77  *      expects one argument, which it returns as result.
  78  *
  79  * Results:
  80  *      A standard Tcl result.
  81  *
  82  * Side effects:
  83  *      See the user documentation.
  84  *
  85  *----------------------------------------------------------------------
  86  */
  87
  88 static int
  89 Pkga_QuoteObjCmd(
  90     ClientData dummy,           /* Not used. */
  91     Tcl_Interp *interp,         /* Current interpreter. */
  92     int objc,                   /* Number of arguments. */
  93     Tcl_Obj *const objv[])      /* Argument strings. */
  94 {
  95     (void)dummy;
  96
  97     if (objc != 2) {
  98         Tcl_WrongNumArgs(interp, 1, objv, "value");
  99         return TCL_ERROR;
 100     }
 101     Tcl_SetObjResult(interp, objv[1]);
 102     return TCL_OK;
 103 }
 104 \f
 105 /*
 106  *----------------------------------------------------------------------
 107  *
 108  * Pkga_Init --
 109  *
 110  *      This is a package initialization procedure, which is called by Tcl
 111  *      when this package is to be added to an interpreter.
 112  *
 113  * Results:
 114  *      None.
 115  *
 116  * Side effects:
 117  *      None.
 118  *
 119  *----------------------------------------------------------------------
 120  */
 121
 122 DLLEXPORT int
 123 Pkga_Init(
 124     Tcl_Interp *interp)         /* Interpreter in which the package is to be
 125                                  * made available. */
 126 {
 127     int code;
 128
 129     if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
 130         return TCL_ERROR;
 131     }
 132     code = Tcl_PkgProvide(interp, "pkga", "1.0");
 133     if (code != TCL_OK) {
 134         return code;
 135     }
 136     Tcl_CreateObjCommand(interp, "pkga_eq", Pkga_EqObjCmd, NULL, NULL);
 137     Tcl_CreateObjCommand(interp, "pkga_quote", Pkga_QuoteObjCmd, NULL,
 138             NULL);
 139     return TCL_OK;
 140 }