home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclOS2Init.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  9KB  |  355 lines
  1. /* 
  2.  * tclOS2Init.c --
  3.  *
  4.  *    Contains the OS/2-specific interpreter initialization functions.
  5.  *
  6.  * Copyright (c) 1994-1996 Sun Microsystems, Inc.
  7.  * Copyright (c) 1996-1997 Illya Vaes
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  */
  12.  
  13. #include "tclInt.h"
  14. #include "tclPort.h"
  15.  
  16. /* Global PM variables, necessary because of event loop and thus console */
  17. HAB hab;
  18. HMQ hmq;
  19. /* Other global variables */
  20. ULONG maxPath;
  21.  
  22. /*
  23.  * The following arrays contain the human readable strings for the OS/2
  24.  * version values.
  25.  */
  26.  
  27. static char* processors[] = { "intel", "ppc" };
  28. static const int numProcessors = sizeof(processors);
  29.  
  30. #ifndef PROCESSOR_ARCHITECTURE_INTEL
  31. #define PROCESSOR_ARCHITECTURE_INTEL 0
  32. #endif
  33. #ifndef PROCESSOR_ARCHITECTURE_PPC
  34. #define PROCESSOR_ARCHITECTURE_PPC   1
  35. #endif
  36. #ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
  37. #define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
  38. #endif
  39.  
  40.  
  41. /*
  42.  * The following string is the startup script executed in new
  43.  * interpreters.  It looks on disk in several different directories
  44.  * for a script "init.tcl" that is compatible with this version
  45.  * of Tcl.  The init.tcl script does all of the real work of
  46.  * initialization.
  47.  */
  48.  
  49. static char *initScript =
  50. "proc init {} {\n\
  51.     global tcl_library tcl_version tcl_patchLevel env\n\
  52.     rename init {}\n\
  53.     set dirs {}\n\
  54.     if [info exists env(TCL_LIBRARY)] {\n\
  55.         lappend dirs $env(TCL_LIBRARY)\n\
  56.     }\n\
  57.     lappend dirs [info library]\n\
  58.     lappend dirs [file dirname [file dirname [info nameofexecutable]]]/lib/tcl$tcl_version\n\
  59.     if [string match {*[ab]*} $tcl_patchLevel] {\n\
  60.         set lib tcl$tcl_patchLevel\n\
  61.     } else {\n\
  62.         set lib tcl$tcl_version\n\
  63.     }\n\
  64.     lappend dirs [file dirname [file dirname [pwd]]]/$lib/library\n\
  65.     lappend dirs [file dirname [pwd]]/library\n\
  66.     foreach i $dirs {\n\
  67.         set tcl_library $i\n\
  68.         if ![catch {uplevel #0 source [list $i/init.tcl]}] {\n\
  69.             return\n\
  70.         }\n\
  71.     }\n\
  72.     set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
  73.     append msg \"    $dirs\n\"\n\
  74.     append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
  75.     error $msg\n\
  76. }\n\
  77. init";
  78.  
  79. /*
  80.  *----------------------------------------------------------------------
  81.  *
  82.  * TclPlatformInit --
  83.  *
  84.  *    Performs OS/2-specific interpreter initialization related to the
  85.  *    tcl_library variable.  Also sets up the HOME environment variable
  86.  *    if it is not already set.
  87.  *
  88.  * Results:
  89.  *    None.
  90.  *
  91.  * Side effects:
  92.  *    Sets "tcl_library" and "env(HOME)" Tcl variables
  93.  *
  94.  *----------------------------------------------------------------------
  95.  */
  96.  
  97. void
  98. TclPlatformInit(interp)
  99.     Tcl_Interp *interp;
  100. {
  101.     char *ptr;
  102.     char buffer[13];
  103.     Tcl_DString ds;
  104.     ULONG sysInfo[QSV_MAX];   /* System Information Data Buffer */
  105.     APIRET rc;
  106.     int cpu = PROCESSOR_ARCHITECTURE_INTEL;
  107.     
  108.     tclPlatform = TCL_PLATFORM_OS2;
  109.  
  110.     Tcl_DStringInit(&ds);
  111.  
  112.     /*
  113.      * Find out what kind of system we are running on.
  114.      */
  115.  
  116.     /* Request all available system information */
  117.     rc= DosQuerySysInfo (1L, QSV_MAX, (PVOID)sysInfo, sizeof(ULONG)*QSV_MAX);
  118.     maxPath = sysInfo[QSV_MAX_PATH_LENGTH - 1];
  119. #ifdef DEBUG
  120.     printf("major version [%d], minor version [%d], rev. [%d], maxPath [%d]\n",
  121.            sysInfo[QSV_VERSION_MAJOR - 1], sysInfo[QSV_VERSION_MINOR - 1],
  122.            sysInfo[QSV_VERSION_REVISION - 1], sysInfo[QSV_MAX_PATH_LENGTH - 1]);
  123. #endif
  124.  
  125.     /*
  126.      * Define the tcl_platform array.
  127.      */
  128.  
  129.     Tcl_SetVar2(interp, "tcl_platform", "platform", "OS/2", TCL_GLOBAL_ONLY);
  130.     Tcl_SetVar2(interp, "tcl_platform", "os", "OS/2", TCL_GLOBAL_ONLY);
  131.     /*
  132.      * Hack for LX-versions above 2.11
  133.      *  OS/2 version    MAJOR MINOR
  134.      *  2.0             20    0
  135.      *  2.1             20    10
  136.      *  2.11            20    11
  137.      *  3.0             20    30
  138.      *  4.0             20    40
  139.      */
  140.     if (sysInfo[QSV_VERSION_MINOR - 1] > 11) {
  141.         int major = (int) (sysInfo[QSV_VERSION_MINOR - 1] / 10);
  142.         sprintf(buffer, "%d.%d", major,
  143.                 (int) sysInfo[QSV_VERSION_MINOR - 1] - major * 10);
  144.     } else {
  145.         sprintf(buffer, "%d.%d", (int) (sysInfo[QSV_VERSION_MAJOR - 1] / 10),
  146.                 (int)sysInfo[QSV_VERSION_MINOR - 1]);
  147.     }
  148.     Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
  149.     /* No API for determining processor (yet) */
  150.     Tcl_SetVar2(interp, "tcl_platform", "machine", processors[cpu],
  151.                 TCL_GLOBAL_ONLY);
  152.  
  153.     Tcl_SetVar(interp, "tcl_library", ".", TCL_GLOBAL_ONLY);
  154.  
  155.     /*
  156.      * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
  157.      * environment variables, if necessary.
  158.      */
  159.  
  160.     ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
  161.     if (ptr == NULL) {
  162.     Tcl_DStringSetLength(&ds, 0);
  163.     ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
  164.     if (ptr != NULL) {
  165.         Tcl_DStringAppend(&ds, ptr, -1);
  166.     }
  167.     ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
  168.     if (ptr != NULL) {
  169.         Tcl_DStringAppend(&ds, ptr, -1);
  170.     }
  171.     if (Tcl_DStringLength(&ds) > 0) {
  172.         Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
  173.             TCL_GLOBAL_ONLY);
  174.     } else {
  175.         Tcl_SetVar2(interp, "env", "HOME", "c:/", TCL_GLOBAL_ONLY);
  176.     }
  177.     }
  178.  
  179.     Tcl_DStringFree(&ds);
  180.  
  181. }
  182.  
  183. /*
  184.  *----------------------------------------------------------------------
  185.  *
  186.  * Tcl_Init --
  187.  *
  188.  *    This procedure is typically invoked by Tcl_AppInit procedures
  189.  *    to perform additional initialization for a Tcl interpreter,
  190.  *    such as sourcing the "init.tcl" script.
  191.  *
  192.  * Results:
  193.  *    Returns a standard Tcl completion code and sets interp->result
  194.  *    if there is an error.
  195.  *
  196.  * Side effects:
  197.  *    Depends on what's in the init.tcl script.
  198.  *
  199.  *----------------------------------------------------------------------
  200.  */
  201.  
  202. int
  203. Tcl_Init(interp)
  204.     Tcl_Interp *interp;        /* Interpreter to initialize. */
  205. {
  206.     return Tcl_Eval(interp, initScript);
  207. }
  208.  
  209. /*
  210.  *----------------------------------------------------------------------
  211.  *
  212.  * TclOS2GetPlatform --
  213.  *
  214.  *      This is a kludge that allows the test library to get access
  215.  *      the internal tclPlatform variable.
  216.  *
  217.  * Results:
  218.  *      Returns a pointer to the tclPlatform variable.
  219.  *
  220.  * Side effects:
  221.  *      None.
  222.  *
  223.  *----------------------------------------------------------------------
  224.  */
  225.  
  226. TclPlatformType *
  227. TclOS2GetPlatform()
  228. {
  229.     return &tclPlatform;
  230. }
  231.  
  232. /*
  233.  *----------------------------------------------------------------------
  234.  *
  235.  * PMInitialize --
  236.  *
  237.  *    Performs OS/2-specific initialization.
  238.  *
  239.  * Results:
  240.  *    True or false depending on intialization.
  241.  *
  242.  * Side effects:
  243.  *    Opens the "PM connection"
  244.  *
  245.  *----------------------------------------------------------------------
  246.  */
  247.  
  248. BOOL
  249. PMInitialize(void)
  250. {
  251.     /* Initialize PM */
  252.     hab = WinInitialize (0);
  253.     if (hab == NULLHANDLE) return FALSE;
  254.     /* Create message queue, increased size from 10 */
  255.     hmq= WinCreateMsgQueue (hab, 64);
  256.     if (hmq == NULLHANDLE) {
  257.         WinTerminate(hab);
  258.         hab= (HAB)0;
  259.         return FALSE;
  260.     }
  261.     return TRUE;
  262. }
  263.  
  264. /*
  265.  *----------------------------------------------------------------------
  266.  *
  267.  * PMShutdown --
  268.  *
  269.  *    Performs OS/2-specific cleanup.
  270.  *
  271.  * Results:
  272.  *    None.
  273.  *
  274.  * Side effects:
  275.  *    Closes the "PM connection"
  276.  *
  277.  *----------------------------------------------------------------------
  278.  */
  279.  
  280. void
  281. PMShutdown(void)
  282. {
  283.     BOOL rc;
  284.  
  285.     /* Reset pointer to arrow */
  286.     rc = WinSetPointer(HWND_DESKTOP,
  287.                        WinQuerySysPointer(HWND_DESKTOP, SPTR_ARROW, FALSE));
  288. #ifdef DEBUG
  289.     if (rc != TRUE) {
  290.         printf("WinSetPointer PMShutdown ERROR: %x\n", WinGetLastError(hab));
  291.     } else {
  292.         printf("WinSetPointer PMShutdown OK\n");
  293.     }
  294. #endif
  295.     WinDestroyMsgQueue(hmq);
  296.     WinTerminate(hab);
  297.     hmq= (HMQ)0;
  298.     hab= (HAB)0;
  299. }
  300.  
  301. /*
  302.  *----------------------------------------------------------------------
  303.  *
  304.  * TclOS2GetHAB --
  305.  *
  306.  *    Get the handle to the anchor block.
  307.  *
  308.  * Results:
  309.  *    HAB or NULLHANDLE.
  310.  *
  311.  * Side effects:
  312.  *    None
  313.  *
  314.  *----------------------------------------------------------------------
  315.  */
  316.  
  317. HAB
  318. TclOS2GetHAB(void)
  319. {
  320.     return hab;
  321. }
  322.  
  323. /*
  324.  *----------------------------------------------------------------------
  325.  *
  326.  * TclPlatformExit --
  327.  *
  328.  *    Cleanup and exit on OS/2.
  329.  *
  330.  * Results:
  331.  *    None. This procedure never returns (it exits the process when
  332.  *    it's done).
  333.  *
  334.  * Side effects:
  335.  *    This procedure terminates all relations with PM.
  336.  *
  337.  *----------------------------------------------------------------------
  338.  */
  339.  
  340. void
  341. TclPlatformExit(status)
  342.     int status;                /* Status to exit with */
  343. {
  344.     /*
  345.      * Set focus to Desktop to force the Terminal edit window to reinstate
  346.      * the system pointer.
  347.      */
  348.     WinSetFocus(HWND_DESKTOP, HWND_DESKTOP);
  349.     WinDestroyMsgQueue(hmq);
  350.     WinTerminate(hab);
  351.     hmq= (HAB)0;
  352.     hab= (HMQ)0;
  353.     exit(status);
  354. }
  355.