home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume26 / tclx / part14 < prev    next >
Encoding:
Text File  |  1991-11-19  |  43.4 KB  |  1,408 lines
  1. Newsgroups: comp.sources.misc
  2. From: karl@sugar.neosoft.com (Karl Lehenbauer)
  3. Subject:  v26i014:  tclx - extensions and on-line help for tcl 6.1, Part14/23
  4. Message-ID: <1991Nov19.135427.1116@sparky.imd.sterling.com>
  5. X-Md4-Signature: f458dc7ae25b454bf9ce981e47366fa3
  6. Date: Tue, 19 Nov 1991 13:54:27 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: karl@sugar.neosoft.com (Karl Lehenbauer)
  10. Posting-number: Volume 26, Issue 14
  11. Archive-name: tclx/part14
  12. Environment: UNIX
  13.  
  14. #! /bin/sh
  15. # This is a shell archive.  Remove anything before this line, then unpack
  16. # it by saving it into a file and typing "sh file".  To overwrite existing
  17. # files, type "sh file -c".  You can also feed this as standard input via
  18. # unshar, or by typing "sh <file", e.g..  If this archive is complete, you
  19. # will see the following message at the end:
  20. #        "End of archive 14 (of 23)."
  21. # Contents:  extended/man/Memory.man extended/src/string.c
  22. #   extended/tclsrc/installTcl.tcl
  23. # Wrapped by karl@one on Wed Nov 13 21:50:27 1991
  24. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  25. if test -f 'extended/man/Memory.man' -a "${1}" != "-c" ; then 
  26.   echo shar: Will not clobber existing file \"'extended/man/Memory.man'\"
  27. else
  28. echo shar: Extracting \"'extended/man/Memory.man'\" \(12997 characters\)
  29. sed "s/^X//" >'extended/man/Memory.man' <<'END_OF_FILE'
  30. X.\"----------------------------------------------------------------------------
  31. X.\" The definitions below are for supplemental macros used in Sprite
  32. X.\" manual entries.
  33. X.\"
  34. X.\" .HS name section [date [version]]
  35. X.\"    Replacement for .TH in other man pages.  See below for valid
  36. X.\"    section names.
  37. X.\"
  38. X.\" .AP type name in/out [indent]
  39. X.\"    Start paragraph describing an argument to a library procedure.
  40. X.\"    type is type of argument (int, etc.), in/out is either "in", "out",
  41. X.\"    or "in/out" to describe whether procedure reads or modifies arg,
  42. X.\"    and indent is equivalent to second arg of .IP (shouldn't ever be
  43. X.\"    needed;  use .AS below instead)
  44. X.\"
  45. X.\" .AS [type [name]]
  46. X.\"    Give maximum sizes of arguments for setting tab stops.  Type and
  47. X.\"    name are examples of largest possible arguments that will be passed
  48. X.\"    to .AP later.  If args are omitted, default tab stops are used.
  49. X.\"
  50. X.\" .BS
  51. X.\"    Start box enclosure.  From here until next .BE, everything will be
  52. X.\"    enclosed in one large box.
  53. X.\"
  54. X.\" .BE
  55. X.\"    End of box enclosure.
  56. X.\"
  57. X.\" .VS
  58. X.\"    Begin vertical sidebar, for use in marking newly-changed parts
  59. X.\"    of man pages.
  60. X.\"
  61. X.\" .VE
  62. X.\"    End of vertical sidebar.
  63. X.\"
  64. X.\" .DS
  65. X.\"    Begin an indented unfilled display.
  66. X.\"
  67. X.\" .DE
  68. X.\"    End of indented unfilled display.
  69. X.\"
  70. X'    # Heading for Sprite man pages
  71. X.de HS
  72. X.if '\\$2'cmds'       .TH \\$1 1 \\$3 \\$4
  73. X.if '\\$2'lib'        .TH \\$1 3 \\$3 \\$4
  74. X.if '\\$2'tcl'        .TH \\$1 3 \\$3 \\$4
  75. X.if '\\$2'tk'         .TH \\$1 3 \\$3 \\$4
  76. X.if t .wh -1.3i ^B
  77. X.nr ^l \\n(.l
  78. X.ad b
  79. X..
  80. X'    # Start an argument description
  81. X.de AP
  82. X.ie !"\\$4"" .TP \\$4
  83. X.el \{\
  84. X.   ie !"\\$2"" .TP \\n()Cu
  85. X.   el          .TP 15
  86. X.\}
  87. X.ie !"\\$3"" \{\
  88. X.ta \\n()Au \\n()Bu
  89. X\&\\$1    \\fI\\$2\\fP    (\\$3)
  90. X.\".b
  91. X.\}
  92. X.el \{\
  93. X.br
  94. X.ie !"\\$2"" \{\
  95. X\&\\$1    \\fI\\$2\\fP
  96. X.\}
  97. X.el \{\
  98. X\&\\fI\\$1\\fP
  99. X.\}
  100. X.\}
  101. X..
  102. X'    # define tabbing values for .AP
  103. X.de AS
  104. X.nr )A 10n
  105. X.if !"\\$1"" .nr )A \\w'\\$1'u+3n
  106. X.nr )B \\n()Au+15n
  107. X.\"
  108. X.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
  109. X.nr )C \\n()Bu+\\w'(in/out)'u+2n
  110. X..
  111. X'    # BS - start boxed text
  112. X'    # ^y = starting y location
  113. X'    # ^b = 1
  114. X.de BS
  115. X.br
  116. X.mk ^y
  117. X.nr ^b 1u
  118. X.if n .nf
  119. X.if n .ti 0
  120. X.if n \l'\\n(.lu\(ul'
  121. X.if n .fi
  122. X..
  123. X'    # BE - end boxed text (draw box now)
  124. X.de BE
  125. X.nf
  126. X.ti 0
  127. X.mk ^t
  128. X.ie n \l'\\n(^lu\(ul'
  129. X.el \{\
  130. X.\"    Draw four-sided box normally, but don't draw top of
  131. X.\"    box if the box started on an earlier page.
  132. X.ie !\\n(^b-1 \{\
  133. X\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
  134. X.\}
  135. X.el \}\
  136. X\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
  137. X.\}
  138. X.\}
  139. X.fi
  140. X.br
  141. X.nr ^b 0
  142. X..
  143. X'    # VS - start vertical sidebar
  144. X'    # ^Y = starting y location
  145. X'    # ^v = 1 (for troff;  for nroff this doesn't matter)
  146. X.de VS
  147. X.mk ^Y
  148. X.ie n 'mc \s12\(br\s0
  149. X.el .nr ^v 1u
  150. X..
  151. X'    # VE - end of vertical sidebar
  152. X.de VE
  153. X.ie n 'mc
  154. X.el \{\
  155. X.ev 2
  156. X.nf
  157. X.ti 0
  158. X.mk ^t
  159. X\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
  160. X.sp -1
  161. X.fi
  162. X.ev
  163. X.\}
  164. X.nr ^v 0
  165. X..
  166. X'    # Special macro to handle page bottom:  finish off current
  167. X'    # box/sidebar if in box/sidebar mode, then invoked standard
  168. X'    # page bottom macro.
  169. X.de ^B
  170. X.ev 2
  171. X'ti 0
  172. X'nf
  173. X.mk ^t
  174. X.if \\n(^b \{\
  175. X.\"    Draw three-sided box if this is the box's first page,
  176. X.\"    draw two sides but no top otherwise.
  177. X.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
  178. X.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
  179. X.\}
  180. X.if \\n(^v \{\
  181. X.nr ^x \\n(^tu+1v-\\n(^Yu
  182. X\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
  183. X.\}
  184. X.bp
  185. X'fi
  186. X.ev
  187. X.if \\n(^b \{\
  188. X.mk ^y
  189. X.nr ^b 2
  190. X.\}
  191. X.if \\n(^v \{\
  192. X.mk ^Y
  193. X.\}
  194. X..
  195. X'    # DS - begin display
  196. X.de DS
  197. X.RS
  198. X.nf
  199. X.sp
  200. X..
  201. X'    # DE - end display
  202. X.de DE
  203. X.fi
  204. X.RE
  205. X.sp .5
  206. X..
  207. X.\"----------------------------------------------------------------------------
  208. X.HS Memory tcl
  209. X.BS
  210. X'@index: memory ckalloc ckfree Tcl_DisplayMemory Tcl_InitMemory Tcl_ValidateAllMemory
  211. X.SH NAME
  212. Xckalloc, memory, ckfree, Tcl_DisplayMemory, Tcl_InitMemory, 
  213. XTcl_ValidateAllMemory - Validated memory allocation interface.
  214. X.SH SYNOPSIS
  215. X.B memory \fBinfo\fR
  216. X.br
  217. X.B memory \fBtrace\fR [\fBon|off\fR]
  218. X.br
  219. X.B memory \fBvalidate\fR [\fBon|off\fR]
  220. X.br
  221. X.B memory \fBtrace_on_at_malloc\fR \fInnn\fR
  222. X.br
  223. X.B memory \fBbreak_on_malloc\fR \fInnn\fR
  224. X.br
  225. X.B memory \fBdisplay\fR \fIfile\fR
  226. X.br
  227. X.sp 2
  228. X.nf
  229. X\fB#include <tcl.h>\fR or \fB<ckalloc.h>\fR
  230. X.sp
  231. Xchar *
  232. X\fBckalloc\fR (\fIsize\fR)
  233. X.sp
  234. Xvoid
  235. X\fBckfree\fR (\fIptr\fR)
  236. X.sp
  237. Xvoid
  238. X\fBTcl_DisplayMemory\fR (fileName)
  239. X.sp
  240. Xvoid
  241. X\fBTcl_InitMemory\fR (\fIinterp\fR)
  242. X.sp
  243. Xvoid
  244. X\fBTcl_ValidateAllMemory\fR (\fIfile, line\fR)
  245. X.SH ARGUMENTS
  246. X.AS Tcl_Interp *fileName
  247. X.AP uint size in
  248. XThe size of the memory block to be allocated.
  249. X.AP char *ptr in
  250. XThe address of a block to free, as returned by ckalloc.
  251. X.AP Tcl_Interp *interp in
  252. XA pointer to the Tcl interpreter.
  253. X.AP char *file in
  254. XThe filename of the caller of Tcl_ValidateAllMemory.
  255. X.AP int line in
  256. XThe line number of the caller of Tcl_ValidateAllMemory.
  257. X.AP char *fileName in
  258. XFile to display list of active memory.
  259. X.BE
  260. X
  261. X.SH DESCRIPTION
  262. X.PP
  263. XThe macro
  264. X\fBckalloc\fR allocates memory, in the same manner as \fBmalloc\fR, with the
  265. Xfollowing differences: One, \fBckalloc\fR checks the value returned from
  266. X\fBmalloc\fR (it calls \fBmalloc\fR for you) and panics if the allocation
  267. Xrequest fails.  Two, if enabled at compile time, a version of \fBckalloc\fR
  268. Xwith special memory debugging capabilities replaces the normal version of
  269. X\fBckalloc\fR, which aids in detecting memory overwrites and leaks (repeated
  270. Xallocations not matched by corresponding frees).
  271. X.PP
  272. X\fBckfree\fR frees memory allocated by \fBckalloc\fR.  Like \fBckalloc\fR,
  273. Xwhen memory debugging is enabled, \fBckfree\fR has enhanced capabilities
  274. Xfor detecting memory overwrites and leaks.
  275. X.PP
  276. XIt is very important that you use \fBckalloc\fR when you need to allocate
  277. Xmemory, and that you use \fBckfree\fR to free it.  Should you use \fBmalloc\fR
  278. Xto allocate and \fBckfree\fR to free, spurious memory
  279. Xvalidation errors will occur when memory debugging is enabled.  Should you
  280. Xuse \fBfree\fR to free memory allocated by \fBckalloc\fR, memory corruption 
  281. Xwill occur when memory debugging is enabled.  Any memory that is to be become
  282. Xthe property of the Tcl interpreter, such as result space, must be allocated
  283. Xwith \fBckalloc\fR.  If it is absolutely necessary for an application to
  284. Xpass back \fBmalloc\fRed memory to Tcl, it will work only if Tcl is complied
  285. Xwith the \fBTCL_MEM_DEBUG\fR flag turned off.  If you convert your application to
  286. Xuse this facility, it will help you find memory over runs and lost memory.
  287. XNote that memory allocated by a C library routine requiring freeing should
  288. Xstill be freed with \fBfree\fR, since it calls \fBmalloc\fR rather than
  289. X\fBckalloc\fR to do the allocation.
  290. X'
  291. X.SH FINDING MEMORY LEAKS
  292. X.PP
  293. XThe function \fBTcl_DisplayMemory\fR will display a list of all currently
  294. Xallocated memory to the specified file.  The following information is
  295. Xdisplayed for each allocated block of memory: starting and ending addresses
  296. X(excluding guard zone), size, source file where \fBckalloc\fR was called to
  297. Xallocate the block and line number in that file.  It is especially useful to
  298. Xcall \fBTcl_DisplayMemory\fR after the Tcl interpreter has been deleted.
  299. X'
  300. X.SH ENABLING MEMORY DEBUGGING
  301. X.PP
  302. XTo enable memory debugging, Tcl should be recompiled from scratch with
  303. X\fBTCL_MEM_DEBUG\fR defined.  This will also compile in
  304. Xa non-stub version of \fBTcl_InitMemory\fR
  305. Xto add the \fBmemory\fR command to Tcl.
  306. X.PP
  307. X\fBTCL_MEM_DEBUG\fR must be either left defined for all modules or undefined
  308. Xfor all modules that are going to be linked together.  If they are not, link
  309. Xerrors will occur, with either \fBTclDbCkfree\fR and \fBTcl_DbCkalloc\fR or
  310. X\fBTcl_Ckalloc\fR and \fBTcl_Ckfree\fR being undefined.
  311. X'
  312. X.SH GUARD ZONES
  313. X.PP
  314. XWhen memory debugging is enabled, whenever a call to \fBckalloc\fR is
  315. Xmade, slightly more memory than requested is allocated so the memory debugging
  316. Xcode can keep track
  317. Xof the allocated memory, and also 
  318. Xeight-byte ``guard zones'' are placed in front of and behind the space that 
  319. Xwill be returned to the caller.  (The size of the guard zone is defined
  320. Xby the C #define \fBGUARD_SIZE\fR in \fIbaseline/src/ckalloc.c\fR -- it
  321. Xcan be extended if you suspect large overwrite problems, at some cost in
  322. Xperformance.)  A known pattern is written into the guard zones and,
  323. Xon a call to \fBckfree\fR, the guard zones of the space being freed
  324. Xare checked to see if either zone has been modified in any way.
  325. XIf one has been, the guard bytes and their new contents are identified,
  326. Xand a ``low guard failed'' or ``high guard failed'' message is issued.
  327. XThe ``guard failed'' message includes the address of the memory packet 
  328. Xand the file name and line number of the code that called \fBckfree\fR.
  329. XThis allows you to detect the common sorts of one-off problems, where
  330. Xnot enough space was allocated to contain the data written, for example.
  331. X'
  332. X.SH THE MEMORY COMMAND
  333. X'@help: misc/memory
  334. X'@brief: display and debug memory problems
  335. X'
  336. X.TP
  337. X.B memory \fIoptions\fR
  338. X.br
  339. XThe Tcl \fBmemory\fR command gives the Tcl developer control of Tcl's memory
  340. Xdebugging capabilities.  The memory command has several suboptions, which are
  341. Xdescribed below.  It is only available when Tcl has been compiled with memory
  342. Xdebugging enabled.
  343. X'
  344. X.TP
  345. X.B memory \fBinfo\fR
  346. X.br
  347. XProduces a report containing the total allocations and frees since 
  348. XTcl began, the current packets allocated (the current
  349. Xnumber of calls to \fBckalloc\fR not met by a corresponding call 
  350. Xto \fBckfree\fR), the current bytes allocated, and the maximum number
  351. Xof packets and bytes allocated.
  352. X'
  353. X.TP
  354. X.B memory \fBtrace\fR [\fBon|off\fR]
  355. X.br
  356. XTurns memory tracing on or off.
  357. XWhen memory tracing is on, every call to \fBckalloc\fR causes a line of
  358. Xtrace information to be written to \fIstderr\fR, consisting of the
  359. Xword \fIckalloc\fR, followed by the address returned, the amount of
  360. Xmemory allocated, and the C filename and line number of the code performing
  361. Xthe allocation, for example...
  362. X.sp
  363. X   \fBckalloc 40e478 98 tclProc.c 1406\fR
  364. X.sp
  365. XCalls to \fBckfree\fR are traced in the same manner, except that the
  366. Xword \fIckalloc\fR is replaced by the word \fIckfree\fR.
  367. X'
  368. X.TP
  369. X.B memory \fBvalidate\fR [\fBon|off\fR]
  370. X.br
  371. XTurns memory vaidation on or off.
  372. XWhen memory validation is enabled, on every call to
  373. X\fBckalloc\fR or \fBckfree\fR, the guard zones are checked for every
  374. Xpiece of memory currently in existence that was allocated by \fBckalloc\fR.
  375. XThis has a large performance impact and should only be used when
  376. Xoverwrite problems are strongly suspected.  The advantage of enabling
  377. Xmemory validation is that a guard zone overwrite can be detected on
  378. Xthe first call to \fBckalloc\fR or \fBckfree\fR after the overwrite
  379. Xoccurred, rather than when the specific memory with the overwritten
  380. Xguard zone(s) is freed, which may occur long after the overwrite occurred.
  381. X'
  382. X.TP
  383. X.B memory \fBtrace_on_at_malloc\fR \fInnn\fR
  384. X.br
  385. XEnable memory tracing after \fInnn\fR \fBckallocs\fR have been performed.
  386. XFor example, if you enter \fBmemory trace_on_at_malloc 100\fR,
  387. Xafter the 100th call to \fBckalloc\fR, memory trace information will begin
  388. Xbeing displayed for all allocations and frees.  Since there can be a lot
  389. Xof memory activity before a problem occurs, judicious use of this option
  390. Xcan reduce the slowdown caused by tracing (and the amount of trace information
  391. Xproduced), if you can identify a number of allocations that occur before
  392. Xthe problem sets in.  The current number of memory allocations that have 
  393. Xoccured since Tcl started is printed on a guard zone failure.
  394. X.TP
  395. X.B memory \fBbreak_on_malloc\fR \fInnn\fR
  396. X.br
  397. XAfter the \fBnnn\fR allocations have been performed, \fBckallocs\fR
  398. Xoutput a message to this effect and that it is now attempting to enter
  399. Xthe C debugger.  Tcl will then issue a \fISIGINT\fR signal against itself.
  400. XIf you are running Tcl under a C debugger, it should then enter the debugger
  401. Xcommand mode.
  402. X'
  403. X.TP
  404. X.B memory \fBdisplay\fR \fIfile\fR
  405. X.br
  406. XWrite a list of all currently allocated memory to the specified file.
  407. X'@endhelp
  408. X'
  409. X.SH DEBUGGING DIFFICULT MEMORY CORRUPTION PROBLEMS
  410. X.PP
  411. XNormally, Tcl compiled with memory debugging enabled will make it easy to isolate
  412. Xa corruption problem.  Turning on memory validation with the memory command
  413. Xcan help isolate difficult problems.
  414. XIf you suspect (or know) that corruption is 
  415. Xoccurring before the Tcl interpreter comes up far enough for you to
  416. Xissue commands, you can set \fBMEM_VALIDATE\fR define, recompile 
  417. XtclCkalloc.c and rebuild Tcl.  This will enable memory validation
  418. Xfrom the first call to \fBckalloc\fR, again, at a large performance impact.
  419. X.PP
  420. XIf you are desperate and validating memory on every call to \fBckalloc\fR
  421. Xand \fBckfree\fR isn't enough, you can explicitly call
  422. X\fBTcl_ValidateAllMemory\fR directly at any point.  It takes a \fIchar *\fR
  423. Xand an \fIint\fR which are normally the filename and line number of the
  424. Xcaller, but they can actually be anything you want.  Remember to remove
  425. Xthe calls after you find the problem.
  426. X'
  427. X.SH KEYWORDS
  428. Xckalloc, ckfree, free, memory, malloc
  429. END_OF_FILE
  430. if test 12997 -ne `wc -c <'extended/man/Memory.man'`; then
  431.     echo shar: \"'extended/man/Memory.man'\" unpacked with wrong size!
  432. fi
  433. # end of 'extended/man/Memory.man'
  434. fi
  435. if test -f 'extended/src/string.c' -a "${1}" != "-c" ; then 
  436.   echo shar: Will not clobber existing file \"'extended/src/string.c'\"
  437. else
  438. echo shar: Extracting \"'extended/src/string.c'\" \(13318 characters\)
  439. sed "s/^X//" >'extended/src/string.c' <<'END_OF_FILE'
  440. X/* 
  441. X * string.c --
  442. X *
  443. X *      Extended TCL string and character manipulation commands.
  444. X *---------------------------------------------------------------------------
  445. X * Copyright 1991 Karl Lehenbauer and Mark Diekhans.
  446. X *
  447. X * Permission to use, copy, modify, and distribute this software and its
  448. X * documentation for any purpose and without fee is hereby granted, provided
  449. X * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  450. X * Mark Diekhans make no representations about the suitability of this
  451. X * software for any purpose.  It is provided "as is" without express or
  452. X * implied warranty.
  453. X */
  454. X
  455. X#include "tclExtdInt.h"
  456. X
  457. X/*
  458. X * Prototypes of internal functions.
  459. X */
  460. Xunsigned int
  461. XExpandString _ANSI_ARGS_((unsigned char *s,
  462. X                          unsigned char  buf[]));
  463. X
  464. X
  465. X/*
  466. X *----------------------------------------------------------------------
  467. X *
  468. X * Tcl_CindexCmd --
  469. X *     Implements the cindex TCL command:
  470. X *         cindex string index
  471. X *
  472. X * Results:
  473. X *      Returns the character indexed by  index  (zero  based)  from
  474. X *      string. 
  475. X *
  476. X *----------------------------------------------------------------------
  477. X */
  478. Xint
  479. XTcl_CindexCmd (clientData, interp, argc, argv)
  480. X    ClientData   clientData;
  481. X    Tcl_Interp  *interp;
  482. X    int          argc;
  483. X    char       **argv;
  484. X{
  485. X    unsigned index;
  486. X
  487. X    if (argc != 3) {
  488. X        Tcl_AppendResult (interp, "wrong # args: ", argv [0], " string index",
  489. X                          (char *) NULL);
  490. X        return TCL_ERROR;
  491. X    }
  492. X
  493. X    if (Tcl_GetUnsigned (interp, argv[2], &index) != TCL_OK)
  494. X        return TCL_ERROR;
  495. X    if (index >= strlen (argv [1]))
  496. X        return TCL_OK;
  497. X
  498. X    interp->result [0] = argv[1][index];
  499. X    interp->result [1] = 0;
  500. X    return TCL_OK;
  501. X
  502. X} /* Tcl_CindexCmd */
  503. X
  504. X/*
  505. X *----------------------------------------------------------------------
  506. X *
  507. X * Tcl_ClengthCmd --
  508. X *     Implements the clength TCL command:
  509. X *         clength string
  510. X *
  511. X * Results:
  512. X *      Returns the length of string in characters. 
  513. X *
  514. X *----------------------------------------------------------------------
  515. X */
  516. Xint
  517. XTcl_ClengthCmd (clientData, interp, argc, argv)
  518. X    ClientData   clientData;
  519. X    Tcl_Interp  *interp;
  520. X    int          argc;
  521. X    char       **argv;
  522. X{
  523. X
  524. X    if (argc != 2) {
  525. X        Tcl_AppendResult (interp, "wrong # args: ", argv [0], " string", 
  526. X                          (char *) NULL);
  527. X        return TCL_ERROR;
  528. X    }
  529. X
  530. X    sprintf (interp->result, "%d", strlen (argv[1]));
  531. X    return TCL_OK;
  532. X
  533. X} /* Tcl_ClengthCmd */
  534. X
  535. X/*
  536. X *----------------------------------------------------------------------
  537. X *
  538. X * Tcl_CrangeCmd --
  539. X *     Implements the crange and csubstr TCL commands:
  540. X *         crange string first last
  541. X *         csubstr string first length
  542. X *
  543. X * Results:
  544. X *      Standard Tcl result.
  545. X *----------------------------------------------------------------------
  546. X */
  547. Xint
  548. XTcl_CrangeCmd (clientData, interp, argc, argv)
  549. X    ClientData   clientData;
  550. X    Tcl_Interp  *interp;
  551. X    int          argc;
  552. X    char       **argv;
  553. X{
  554. X    unsigned  fullLen, first;
  555. X    unsigned  subLen;
  556. X    char     *strPtr;
  557. X    char      holdChar;
  558. X    int       isRange = (argv [0][1] == 'r');  /* csubstr or crange */
  559. X
  560. X    if (argc != 4) {
  561. X        Tcl_AppendResult (interp, "wrong # args: ", argv [0], 
  562. X                          " string first ", 
  563. X                          (isRange) ? "last" : "length",
  564. X                          (char *) NULL);
  565. X        return TCL_ERROR;
  566. X    }
  567. X
  568. X    if (Tcl_GetUnsigned (interp, argv[2], &first) != TCL_OK)
  569. X        return TCL_ERROR;
  570. X
  571. X    fullLen = strlen (argv [1]);
  572. X    if (first >= fullLen)
  573. X        return TCL_OK;
  574. X
  575. X    if (STREQU (argv[3], "end"))
  576. X        subLen = fullLen - first;
  577. X    else {
  578. X        if (Tcl_GetUnsigned (interp, argv[3], &subLen) != TCL_OK)
  579. X            return TCL_ERROR;
  580. X        
  581. X        if (isRange) {
  582. X            if (subLen < first) {
  583. X                Tcl_AppendResult (interp, "last is before first",
  584. X                                  (char *) NULL);
  585. X                return TCL_ERROR;
  586. X            }
  587. X            subLen = subLen - first +1;
  588. X        }
  589. X
  590. X        if (first + subLen > fullLen)
  591. X            subLen = fullLen - first;
  592. X    }
  593. X
  594. X    strPtr = argv [1] + first;
  595. X
  596. X    holdChar = strPtr [subLen];
  597. X    strPtr [subLen] = '\0';
  598. X    Tcl_SetResult (interp, strPtr, TCL_VOLATILE);
  599. X    strPtr [subLen] = holdChar;
  600. X
  601. X    return TCL_OK;
  602. X
  603. X} /* Tcl_CrangeCmd */
  604. X
  605. X/*
  606. X *----------------------------------------------------------------------
  607. X *
  608. X * Tcl_ReplicateCmd --
  609. X *     Implements the replicate TCL command:
  610. X *         replicate string count
  611. X *     See the string(TCL) manual page.
  612. X *
  613. X * Results:
  614. X *      Returns string replicated count times.
  615. X *
  616. X *----------------------------------------------------------------------
  617. X */
  618. Xint
  619. XTcl_ReplicateCmd (clientData, interp, argc, argv)
  620. X    ClientData   clientData;
  621. X    Tcl_Interp  *interp;
  622. X    int          argc;
  623. X    char       **argv;
  624. X{
  625. X    unsigned       repCount;
  626. X    register char *srcPtr, *scanPtr, *newPtr;
  627. X    register int   newLen, cnt;
  628. X
  629. X    if (argc != 3) {
  630. X        Tcl_AppendResult (interp, "wrong # args: ", argv [0], 
  631. X                          " string count", (char *) NULL);
  632. X        return TCL_ERROR;
  633. X    }
  634. X
  635. X    if (Tcl_GetUnsigned (interp, argv[2], &repCount) != TCL_OK)
  636. X        return TCL_ERROR;
  637. X
  638. X    srcPtr = argv [1];
  639. X    newLen = strlen (srcPtr) * repCount;
  640. X    if (newLen >= TCL_RESULT_SIZE)
  641. X        Tcl_SetResult (interp, ckalloc ((unsigned) newLen + 1), TCL_DYNAMIC);
  642. X
  643. X    newPtr = interp->result;
  644. X    for (cnt = 0; cnt < repCount; cnt++) {
  645. X        for (scanPtr = srcPtr; *scanPtr != 0; scanPtr++)
  646. X            *newPtr++ = *scanPtr;
  647. X    }
  648. X    *newPtr = 0;
  649. X
  650. X    return TCL_OK;
  651. X
  652. X} /* Tcl_ReplicateCmd */
  653. X
  654. X/*
  655. X *----------------------------------------------------------------------
  656. X *
  657. X * ExpandString --
  658. X *  Build an expand version of a translit range specification.
  659. X *
  660. X * Results:
  661. X *  TRUE it the expansion is ok, FALSE it its too long.
  662. X *
  663. X *----------------------------------------------------------------------
  664. X */
  665. X#define MAX_EXPANSION 255
  666. X
  667. Xstatic unsigned int
  668. XExpandString (s, buf)
  669. X    unsigned char *s;
  670. X    unsigned char  buf[];
  671. X{
  672. X    int i, j;
  673. X
  674. X    i = 0;
  675. X    while((*s !=0) && i < MAX_EXPANSION) {
  676. X        if(s[1] == '-' && s[2] > s[0]) {
  677. X            for(j = s[0]; j <= s[2]; j++)
  678. X                buf[i++] = j;
  679. X            s += 3;
  680. X        } else
  681. X            buf[i++] = *s++;
  682. X    }
  683. X    buf[i] = 0;
  684. X    return (i < MAX_EXPANSION);
  685. X}
  686. X
  687. X/*
  688. X *----------------------------------------------------------------------
  689. X *
  690. X * Tcl_TranslitCmd --
  691. X *     Implements the TCL translit command:
  692. X *     translit inrange outrange string
  693. X *
  694. X * Results:
  695. X *  Standard TCL results.
  696. X *
  697. X *----------------------------------------------------------------------
  698. X */
  699. Xint
  700. XTcl_TranslitCmd (clientData, interp, argc, argv)
  701. X    ClientData  clientData;
  702. X    Tcl_Interp *interp;
  703. X    int         argc;
  704. X    char       **argv;
  705. X{
  706. X    unsigned char from [MAX_EXPANSION+1];
  707. X    unsigned char to   [MAX_EXPANSION+1];
  708. X    unsigned char map  [MAX_EXPANSION+1];
  709. X    unsigned char *s, *t;
  710. X    int i;
  711. X
  712. X    if (argc != 4) {
  713. X        Tcl_AppendResult (interp, "wrong # args: ", argv [0], 
  714. X                          " from to string", (char *) NULL);
  715. X        return TCL_ERROR;
  716. X    }
  717. X
  718. X    if (!ExpandString (argv[1], from)) {
  719. X        interp->result = "inrange expansion too long";
  720. X        return TCL_ERROR;
  721. X    }
  722. X
  723. X    if (!ExpandString (argv[2], to)) {
  724. X        interp->result = "outrange expansion too long";
  725. X        return TCL_ERROR;
  726. X    }
  727. X
  728. X    for(i = 0; i <= MAX_EXPANSION ; i++)
  729. X        map[i] = i;
  730. X
  731. X    for(i = 0; to[i] != 0; i++)
  732. X        if(from[i])
  733. X            map[from[i]] = to[i];
  734. X        else
  735. X            break;
  736. X    if(to[i] != 0) {
  737. X        interp->result = "inrange longer than outrange";
  738. X        return TCL_ERROR;
  739. X    }
  740. X
  741. X    for(; from[i]; i++)
  742. X        map[from[i]] = 0;
  743. X
  744. X    for (s = t = (unsigned char *)argv[3]; *s; s++) {
  745. X        if(map[*s])
  746. X            *t++ = map[*s];
  747. X    }
  748. X    *t = 0;
  749. X
  750. X    Tcl_SetResult (interp, argv[3], TCL_VOLATILE);
  751. X
  752. X    return TCL_OK;
  753. X}
  754. X
  755. X/*
  756. X *----------------------------------------------------------------------
  757. X *
  758. X * Tcl_CtypeCmd --
  759. X *
  760. X *      This function implements the 'ctype' command:
  761. X *      ctype class string
  762. X *
  763. X *      Where class is one of the following:
  764. X *        digit, xdigit, lower, upper, alpha, alnum,
  765. X *        space, cntrl,  punct, print, graph, ascii, char or ord.
  766. X *
  767. X * Results:
  768. X *       One or zero: Depending if all the characters in the string are of
  769. X *       the desired class.  Char and ord provide conversions and return the
  770. X *       converted value.
  771. X *
  772. X *----------------------------------------------------------------------
  773. X */
  774. Xint
  775. XTcl_CtypeCmd (clientData, interp, argc, argv)
  776. X    ClientData   clientData;
  777. X    Tcl_Interp  *interp;
  778. X    int          argc;
  779. X    char       **argv;
  780. X{
  781. X    register char *class;
  782. X    register char *scanPtr;
  783. X
  784. X    if (argc != 3) {
  785. X        Tcl_AppendResult (interp, "wrong # args: ", argv [0], " class string",
  786. X                          (char *) NULL);
  787. X        return TCL_ERROR;
  788. X    }
  789. X
  790. X    class = argv [1];
  791. X
  792. X    /*
  793. X     * Handle conversion requests.
  794. X     */
  795. X    if (STREQU (class, "char")) {
  796. X        int number;
  797. X
  798. X        if (Tcl_GetInt (interp, argv [2], &number) != TCL_OK)
  799. X            return TCL_ERROR;
  800. X        if ((number < 0) || (number > 255)) {
  801. X            Tcl_AppendResult (interp, "number must be in the range 0..255",
  802. X                              (char *) NULL);
  803. X            return TCL_ERROR;
  804. X        }
  805. X
  806. X        interp->result [0] = number;
  807. X        interp->result [1] = 0;
  808. X        return TCL_OK;
  809. X    }
  810. X
  811. X    if (STREQU (class, "ord")) {
  812. X        if (strlen (argv [2]) != 1) {
  813. X            Tcl_AppendResult (interp, "string to convert must be only one",
  814. X                              " character", (char *) NULL);
  815. X            return TCL_ERROR;
  816. X        }
  817. X
  818. X        sprintf(interp->result, "%d", (int)(*argv[2]));
  819. X        return TCL_OK;
  820. X    }
  821. X
  822. X    /*
  823. X     * Select based on the first letter of the 'class' argument to chose the 
  824. X     * macro to test characters with.  In some cases another character must be
  825. X     * switched on to determine which macro to use.  This is gross, but better
  826. X     * we only have to do a string compare once to test if class is correct.
  827. X     */
  828. X    if ((class [2] == 'n') && STREQU (class, "alnum")) {
  829. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  830. X            if (!isalnum (*scanPtr))
  831. X                break;
  832. X        }
  833. X        goto returnResult;
  834. X    }
  835. X    if ((class [2] == 'p') && STREQU (class, "alpha")) {
  836. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  837. X            if (! isalpha (*scanPtr))
  838. X                break;
  839. X        }
  840. X        goto returnResult;
  841. X    }
  842. X    if ((class [1] == 's') && STREQU (class, "ascii")) {
  843. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  844. X            if (!isascii (*scanPtr))
  845. X                break;
  846. X        }
  847. X        goto returnResult;
  848. X    }
  849. X    if (STREQU (class, "cntrl")) {
  850. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  851. X            if (!iscntrl (*scanPtr))
  852. X                break;
  853. X        }
  854. X        goto returnResult;
  855. X    }
  856. X    if (STREQU (class, "digit")) {
  857. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  858. X            if (!isdigit (*scanPtr))
  859. X                break;
  860. X        }
  861. X        goto returnResult;
  862. X    }
  863. X    if (STREQU (class, "graph")) {
  864. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  865. X            if (!isgraph (*scanPtr))
  866. X                break;
  867. X        }
  868. X        goto returnResult;
  869. X    }
  870. X    if (STREQU (class, "lower")) {
  871. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  872. X            if (!islower (*scanPtr))
  873. X                break;
  874. X        }
  875. X        goto returnResult;
  876. X    }
  877. X    if ((class [1] == 'r') && STREQU (class, "print")) {
  878. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  879. X            if (!isprint (*scanPtr))
  880. X                break;
  881. X        }
  882. X        goto returnResult;
  883. X    }
  884. X    if ((class [1] == 'u') && STREQU (class, "punct")) {
  885. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  886. X            if (!ispunct (*scanPtr))
  887. X                break;
  888. X        }
  889. X        goto returnResult;
  890. X    }
  891. X    if (STREQU (class, "space")) {
  892. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  893. X            if (!isspace (*scanPtr))
  894. X                break;
  895. X        }
  896. X        goto returnResult;
  897. X    }
  898. X    if (STREQU (class, "upper")) {
  899. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  900. X            if (!isupper (*scanPtr))
  901. X                break;
  902. X        }
  903. X        goto returnResult;
  904. X    }
  905. X    if (STREQU (class, "xdigit")) {
  906. X        for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  907. X            if (!isxdigit (*scanPtr))
  908. X                break;
  909. X        }
  910. X        goto returnResult;
  911. X    }
  912. X    /*
  913. X     * No match on subcommand.
  914. X     */
  915. X    Tcl_AppendResult (interp, "unrecognized class specification: \"", class,
  916. X                      "\", expected one of: alnum, alpha, ascii, char, ",
  917. X                      "cntrl, digit, graph, lower, ord, print, punct, space, ",
  918. X                      "upper or xdigit", (char *) NULL);
  919. X    return TCL_ERROR;
  920. X
  921. X    /*
  922. X     * Return true or false, depending if the end was reached.  Always return 
  923. X     * false for a null string.
  924. X     */
  925. XreturnResult:
  926. X    interp->result [0] = (*scanPtr == 0 && scanPtr != argv [2]) ? '1' : '0';
  927. X    interp->result [1] = 0;
  928. X    return TCL_OK;
  929. X
  930. X}
  931. X
  932. END_OF_FILE
  933. if test 13318 -ne `wc -c <'extended/src/string.c'`; then
  934.     echo shar: \"'extended/src/string.c'\" unpacked with wrong size!
  935. fi
  936. # end of 'extended/src/string.c'
  937. fi
  938. if test -f 'extended/tclsrc/installTcl.tcl' -a "${1}" != "-c" ; then 
  939.   echo shar: Will not clobber existing file \"'extended/tclsrc/installTcl.tcl'\"
  940. else
  941. echo shar: Extracting \"'extended/tclsrc/installTcl.tcl'\" \(13571 characters\)
  942. sed "s/^X//" >'extended/tclsrc/installTcl.tcl' <<'END_OF_FILE'
  943. X#==============================================================================
  944. X# installTcl.tcl -- 
  945. X#
  946. X# Tcl program to install Tcl onto the system.  It is run in the following
  947. X# manner:
  948. X#
  949. X#     tcl installTcl.tcl configFile
  950. X#
  951. X# configFile is a Tcl file that is sourced and contains and sets the following
  952. X# variables:  See the makefile for the definition of each of the variables:
  953. X#
  954. X#   o TCL_UCB_DIR
  955. X#   o TCL_DEFAULT
  956. X#   o TCL_OWNER
  957. X#   o TCL_GROUP
  958. X#   o TCL_BINDIR
  959. X#   o TCL_LIBDIR
  960. X#   o TCL_INCLUDEDIR
  961. X#   o TCL_TCLDIR
  962. X#   o TCL_MAN_INSTALL
  963. X#   o TCL_MAN_BASEDIR
  964. X#   o TCL_MAN_SECTION
  965. X#   o TCL_MAN_STYLE
  966. X#   o TCL_MAN_INDEX
  967. X#   o TCL_MAN_INDEX_MERGE
  968. X#
  969. X# Notes:
  970. X#   Must be run in the Tcl top level directory.
  971. X#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  972. X
  973. X#------------------------------------------------------------------------------
  974. X# GiveAwayFile --
  975. X#   Give away a file to the Tcl owner and group and set its permissions.
  976. X#
  977. X# Globals:
  978. X#    TCL_OWNER - Owner name for Tcl files.
  979. X#    TCL_GROUP - Group nmae for Tcl file.
  980. X#------------------------------------------------------------------------------
  981. X
  982. Xproc GiveAwayFile {file} {
  983. X    global TCL_OWNER TCL_GROUP
  984. X
  985. X    if {[file isdirectory $file]} {
  986. X        chmod a+rx,go-w $file
  987. X    } else {
  988. X        chmod a+r,go-w $file
  989. X    }    
  990. X    chown [list $TCL_OWNER $TCL_GROUP] $file
  991. X
  992. X} ;# GiveAwayFile
  993. X
  994. X#------------------------------------------------------------------------------
  995. X# MakePath --
  996. X#
  997. X# Make sure all directories in a directory path exists, if not, create them.
  998. X#------------------------------------------------------------------------------
  999. Xproc MakePath {pathlist} {
  1000. X    foreach path $pathlist {
  1001. X        set exploded_path [split $path /]
  1002. X        set thisdir {}
  1003. X        foreach element $exploded_path {
  1004. X            append thisdir $element
  1005. X            if {![file isdirectory $thisdir]} {
  1006. X                mkdir $thisdir
  1007. X                GiveAwayFile $thisdir
  1008. X            }
  1009. X            append thisdir /
  1010. X        }
  1011. X    }
  1012. X}
  1013. X
  1014. X#------------------------------------------------------------------------------
  1015. X# CopyFile -- 
  1016. X#
  1017. X# Copy the specified file and change the ownership.  If target is a directory,
  1018. X# then the file is copied to it, other target is a new file name.
  1019. X#------------------------------------------------------------------------------
  1020. X
  1021. Xproc CopyFile {sourceFile target} {
  1022. X
  1023. X    if {[file isdirectory $target]} {
  1024. X        set targetFile "$target/[file tail $sourceFile]"
  1025. X    } else {
  1026. X        set targetFile $target
  1027. X    }
  1028. X
  1029. X    set sourceFH [open $sourceFile r]
  1030. X    set targetFH [open $targetFile w]
  1031. X    copyfile $sourceFH $targetFH
  1032. X    close $sourceFH
  1033. X    close $targetFH
  1034. X    GiveAwayFile $targetFile
  1035. X
  1036. X} ;# CopyFile
  1037. X
  1038. X#------------------------------------------------------------------------------
  1039. X# CopySubDir --
  1040. X#
  1041. X# Recursively copy part of a directory tree, changing ownership and 
  1042. X# permissions.  This is a utility routine that actually does the copying.
  1043. X#------------------------------------------------------------------------------
  1044. X
  1045. Xproc CopySubDir {sourceDir destDir} {
  1046. X    foreach sourceFile [glob -nocomplain $sourceDir/*] {
  1047. X
  1048. X        if [file isdirectory $sourceFile] {
  1049. X            set destFile $destDir/[file tail $sourceFile]
  1050. X            if {![file exists $destFile]} {
  1051. X                mkdir $destFile}
  1052. X            GiveAwayFile $destFile
  1053. X            CopySubDir $sourceFile $destFile
  1054. X        } else {
  1055. X            CopyFile $sourceFile $destDir
  1056. X        }
  1057. X    }
  1058. X} ;# CopySubDir
  1059. X
  1060. X#------------------------------------------------------------------------------
  1061. X# CopyDir --
  1062. X#
  1063. X# Recurisvely copy a directory tree.
  1064. X#------------------------------------------------------------------------------
  1065. X
  1066. Xproc CopyDir {sourceDir destDir} {
  1067. X
  1068. X    set cwd [pwd]
  1069. X    if ![file exists $sourceDir] {
  1070. X        error "\"$sourceDir\" does not exist"
  1071. X    }
  1072. X    if ![file isdirectory $sourceDir] {
  1073. X        error "\"$sourceDir\" isn't a directory"
  1074. X    }
  1075. X    if {![file exists $destDir]} {
  1076. X        mkdir $destDir
  1077. X        GiveAwayFile $destDir
  1078. X    }
  1079. X    if ![file isdirectory $destDir] {
  1080. X        error "\"$destDir\" isn't a directory"
  1081. X    }
  1082. X    cd $sourceDir
  1083. X    set status [catch {CopySubDir . $destDir} msg]
  1084. X    cd $cwd
  1085. X    if {$status != 0} {
  1086. X        global errorInfo errorCode
  1087. X        error $msg $errorInfo $errorCode
  1088. X    }
  1089. X}
  1090. X
  1091. X#------------------------------------------------------------------------------
  1092. X# GenDefaultFile -- 
  1093. X#
  1094. X# Generate the tcl defaults file.
  1095. X#------------------------------------------------------------------------------
  1096. X
  1097. Xproc GenDefaultFile {defaultFileBase sourceDir} {
  1098. X
  1099. X    set defaultFile "$defaultFileBase[infox version]"
  1100. X
  1101. X    if ![file writable [file dirname $defaultFile]] {
  1102. X        puts stderr "Can't create $defaultFile -- directory is not writable"
  1103. X        puts stderr "Please reinstall with correct permissions or rebuild"
  1104. X        puts stderr "Tcl to select a default file where the directory path"
  1105. X        puts stderr "you specify is writable by you."
  1106. X        puts stderr ""
  1107. X        puts stderr "Tcl will still be runnable from the current directory,"
  1108. X        puts stderr "but maybe not any others..."
  1109. X        puts stderr ""
  1110. X        exit 1
  1111. X    }
  1112. X
  1113. X    set fp [open $defaultFile w]
  1114. X
  1115. X    puts $fp "# Extended Tcl [infox version] default file"
  1116. X    puts $fp ""
  1117. X    puts $fp "set TCLINIT $sourceDir/TclInit.tcl"
  1118. X    puts $fp ""
  1119. X    puts $fp "set TCLPATH $sourceDir"
  1120. X
  1121. X    close $fp
  1122. X    GiveAwayFile $defaultFile
  1123. X
  1124. X} ;# GenDefaultFile
  1125. X
  1126. X#------------------------------------------------------------------------------
  1127. X# InstallShortMan --
  1128. X#   Install a manual page on a system that does not have long file names,
  1129. X#   optionally adding an entry to the man index.
  1130. X#
  1131. X# Parameters:
  1132. X#   o sourceDir - Directory containing the file.
  1133. X#   o manNames - Name entry created from the name line of the file by
  1134. X#     buildhelp.  Has file name and the names it is to be known by.
  1135. X#   o indexFileHdl - File handle of the current index file being created, or
  1136. X#     empty if no index is to be created.
  1137. X# Globals
  1138. X#   o TCL_MAN_BASEDIR - Base manual directory where all of the man.* and cat.* 
  1139. X#     directories live.
  1140. X#   o TCL_MAN_SECTION - The section that the manual file is to go in.
  1141. X#   o TCL_MAN_SEPARATOR - The name separator between the directory and the
  1142. X#     section.
  1143. X#------------------------------------------------------------------------------
  1144. X
  1145. Xproc InstallShortMan {sourceDir manNames indexFileHdl} {
  1146. X    global TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR
  1147. X
  1148. X    set srcManFilePath "$sourceDir/[lindex $manNames 0]"
  1149. X    set manFileBase [file tail [file root $srcManFilePath]]
  1150. X
  1151. X    set destManDir "$TCL_MAN_BASEDIR/man$TCL_MAN_SEPARATOR$TCL_MAN_SECTION"
  1152. X
  1153. X    CopyFile $srcManFilePath "$destManDir/$manFileBase.$TCL_MAN_SECTION"
  1154. X
  1155. X    if {![lempty $indexFileHdl]} {
  1156. X        foreach name [lindex $manNames 1] {
  1157. X            puts $indexFileHdl "$name\t$manFileBase\t$TCL_MAN_SECTION"
  1158. X        }
  1159. X    }    
  1160. X
  1161. X} ;# InstallShortMan
  1162. X
  1163. X#------------------------------------------------------------------------------
  1164. X# InstallShortManPages --
  1165. X#   Install the manual pages using the short file name scheme.
  1166. X#------------------------------------------------------------------------------
  1167. X
  1168. Xproc InstallShortManPages {} {
  1169. X    global TCL_UCB_DIR   TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR
  1170. X    global TCL_MAN_INDEX TCL_MAN_INDEX_MERGE
  1171. X
  1172. X    set targetDir "$TCL_MAN_BASEDIR/man$TCL_MAN_SEPARATOR$TCL_MAN_SECTION"
  1173. X
  1174. X    MakePath  $TCL_MAN_BASEDIR 
  1175. X    MakePath  $targetDir
  1176. X    MakePath "$TCL_MAN_BASEDIR/cat$TCL_MAN_SEPARATOR$TCL_MAN_SECTION"
  1177. X
  1178. X    if {$TCL_MAN_INDEX} {
  1179. X        set tclIndexFile $TCL_MAN_BASEDIR/index.TCL
  1180. X        set indexFileHdl [open $tclIndexFile w]
  1181. X    } else {
  1182. X        set indexFileHdl {}
  1183. X    }
  1184. X
  1185. X    # Install all of the actual files.
  1186. X
  1187. X    echo "    Installing Tcl 6.1 man files to $targetDir"
  1188. X
  1189. X    for_file manNames "ucbsrc/ucbman.names" {
  1190. X        InstallShortMan $TCL_UCB_DIR/doc $manNames $indexFileHdl
  1191. X    }
  1192. X
  1193. X    echo "    Installing Extended Tcl man files to $targetDir"
  1194. X
  1195. X    for_file manNames "man/extdman.names" {
  1196. X        InstallShortMan man $manNames $indexFileHdl
  1197. X    }
  1198. X
  1199. X    if {$TCL_MAN_INDEX} {
  1200. X        close $indexFileHdl
  1201. X        GiveAwayFile $tclIndexFile
  1202. X    }
  1203. X
  1204. X    # Merge the manual index, if requested.
  1205. X
  1206. X    if {$TCL_MAN_INDEX_MERGE} {
  1207. X        set indexFile $TCL_MAN_BASEDIR/index
  1208. X        if {![file exists $indexFile]} {
  1209. X            echo ""
  1210. X            echo [replicate "*" 60]
  1211. X            echo "* `$indexFile' man index file found."
  1212. X            echo "* you may not have manual indexs on this system."
  1213. X            echo "* File `$tclIndexFile' built,"
  1214. X            echo "* but indexes not merged."
  1215. X            echo [replicate "*" 60]
  1216. X            echo ""
  1217. X        } else {
  1218. X            echo "    Generating new manual index: $indexFile"
  1219. X            exec cat $indexFile $tclIndexFile | sort -u > ${indexFile}.new
  1220. X            exec mv $indexFile ${indexFile}.bak
  1221. X            exec mv ${indexFile}.new $indexFile
  1222. X            GiveAwayFile $indexFile
  1223. X        }
  1224. X    }    
  1225. X} ;# InstallShortManPages
  1226. X
  1227. X#------------------------------------------------------------------------------
  1228. X# InstallLongMan --
  1229. X#   Install a manual page on a system that does have long file names.
  1230. X#
  1231. X# Parameters:
  1232. X#   o sourceDir - Directory containing the file.
  1233. X#   o manNames - Name entry created from the name line of the file by
  1234. X#     buildhelp.  Has file name and the names it is to be known by.
  1235. X# Globals
  1236. X#   o TCL_MAN_BASEDIR - Base manual directory where all of the man.* and cat.* 
  1237. X#     directories live.
  1238. X#   o TCL_MAN_SECTION - The section that the manual file is to go in.
  1239. X#   o TCL_MAN_SEPARATOR - The name separator between the directory and the
  1240. X#     section.
  1241. X#------------------------------------------------------------------------------
  1242. X
  1243. Xproc InstallLongMan {sourceDir manNames} {
  1244. X    global TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR
  1245. X
  1246. X    set srcManFilePath "$sourceDir/[lindex $manNames 0]"
  1247. X    set manFileBase [file tail [file root $srcManFilePath]]
  1248. X
  1249. X    set manLongNames [lindex $manNames 1]
  1250. X
  1251. X    set destManDir "$TCL_MAN_BASEDIR/man$TCL_MAN_SEPARATOR$TCL_MAN_SECTION"
  1252. X    set destManFile "$destManDir/[lvarpop manLongNames].$TCL_MAN_SECTION"
  1253. X
  1254. X    # Copy file to the first name in the list.
  1255. X
  1256. X    CopyFile $srcManFilePath $destManFile
  1257. X
  1258. X    # Link it to the rest of the names in the list.
  1259. X
  1260. X    foreach manEntry $manLongNames {
  1261. X        link $destManFile "$destManDir/$manEntry.$TCL_MAN_SECTION"
  1262. X    }
  1263. X
  1264. X} ;# InstallLongMan
  1265. X
  1266. X#------------------------------------------------------------------------------
  1267. X# InstallLongManPages --
  1268. X#   Install the manual pages using the long file name scheme.
  1269. X#------------------------------------------------------------------------------
  1270. X
  1271. Xproc InstallLongManPages {} {
  1272. X    global TCL_UCB_DIR   TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR
  1273. X
  1274. X    set targetDir "$TCL_MAN_BASEDIR/man$TCL_MAN_SEPARATOR$TCL_MAN_SECTION"
  1275. X
  1276. X    MakePath  $TCL_MAN_BASEDIR 
  1277. X    MakePath  $targetDir
  1278. X    MakePath "$TCL_MAN_BASEDIR/cat$TCL_MAN_SEPARATOR$TCL_MAN_SECTION"
  1279. X
  1280. X    # Install all of the actual files.
  1281. X
  1282. X    echo "    Installing Tcl 6.1 man files to $targetDir"
  1283. X
  1284. X    for_file manNames "ucbsrc/ucbman.names" {
  1285. X        InstallLongMan $TCL_UCB_DIR/doc $manNames
  1286. X    }
  1287. X
  1288. X    echo "    Installing Extended Tcl man files to $targetDir"
  1289. X
  1290. X    for_file manNames "man/extdman.names" {
  1291. X        InstallLongMan man $manNames
  1292. X    }
  1293. X
  1294. X} ;# InstallLongManPages
  1295. X
  1296. X#------------------------------------------------------------------------------
  1297. X# Main program code.
  1298. X#------------------------------------------------------------------------------
  1299. X
  1300. Xecho ""
  1301. Xecho ">>> Installing Extended Tcl [infox version] <<<"
  1302. X
  1303. Xset argc [llength $argv]
  1304. Xif {$argc != 1} {
  1305. X    puts stderr "usage: tcl installTcl.tcl configFile"
  1306. X    exit 1
  1307. X}
  1308. X
  1309. Xglobal TCL_UCB_DIR     TCL_DEFAULT     TCL_OWNER         TCL_GROUP  TCL_BINDIR
  1310. Xglobal TCL_LIBDIR      TCL_INCLUDEDIR  TCL_TCLDIR        TCL_MAN_INSTALL
  1311. Xglobal TCL_MAN_BASEDIR TCL_MAN_SECTION TCL_MAN_SEPARATOR TCL_MAN_STYLE
  1312. Xglobal TCL_MAN_INDEX   TCL_MAN_INDEX_MERGE
  1313. X
  1314. Xsource $argv
  1315. X
  1316. Xglobal G_longFileNames
  1317. X
  1318. X
  1319. X#
  1320. X# Determine if long file names are available
  1321. X#
  1322. Xset status [catch {set tmpFH [open $libDir/AVeryVeryBigFileName w]}]
  1323. Xif {$status != 0} {
  1324. X    set G_longFileNames 0
  1325. X} else {
  1326. X    close $tmpFH
  1327. X    unlink $libDir/AVeryVeryBigFileName
  1328. X    set G_longFileNames 1
  1329. X}
  1330. X
  1331. X#
  1332. X# Make sure all directories exists that we will be installing in.
  1333. X#
  1334. X
  1335. XMakePath [list $TCL_TCLDIR [file dirname $TCL_DEFAULT] $TCL_BINDIR]
  1336. XMakePath [list $TCL_LIBDIR $TCL_INCLUDEDIR $TCL_TCLDIR]
  1337. X
  1338. Xecho "    Creating default file: $TCL_DEFAULT[infox version]"
  1339. XGenDefaultFile $TCL_DEFAULT $TCL_TCLDIR
  1340. X
  1341. Xecho "    Installing `tcl' program in: $TCL_BINDIR"
  1342. XCopyFile tcl $TCL_BINDIR
  1343. Xchmod +rx $TCL_BINDIR/tcl
  1344. X
  1345. Xecho "    Installing `libtcl.a' library in: $TCL_LIBDIR"
  1346. XCopyFile libtcl.a $TCL_LIBDIR
  1347. X
  1348. Xecho "    Installing Tcl .h files in: $TCL_INCLUDEDIR"
  1349. XCopyFile $TCL_UCB_DIR/tcl.h $TCL_INCLUDEDIR
  1350. XCopyFile src/tclExtend.h $TCL_INCLUDEDIR
  1351. XCopyFile src/tcl++.h $TCL_INCLUDEDIR
  1352. X
  1353. Xecho "    Installing Tcl source files in: $TCL_TCLDIR"
  1354. Xforeach srcFile [glob tcllib/*] {
  1355. X    if {![file isdirectory $srcFile]} {
  1356. X        CopyFile $srcFile $TCL_TCLDIR
  1357. X    }
  1358. X}
  1359. X
  1360. Xecho "    Installing Tcl help files in: $TCL_TCLDIR/help"
  1361. XCopyDir tcllib/help          $TCL_TCLDIR/help
  1362. X
  1363. Xforeach file [glob $TCL_TCLDIR/*.tlib] {
  1364. X    buildpackageindex $file
  1365. X}
  1366. X
  1367. Xif {$TCL_MAN_INSTALL} {
  1368. X    case $TCL_MAN_STYLE in {
  1369. X        {short} InstallShortManPages
  1370. X        {long} InstallLongManPages
  1371. X        default {error "invalid value for TCL_MAN_STYLE: `$TCL_MAN_STYLE'"}
  1372. X    }
  1373. X}
  1374. X
  1375. Xecho "     *** TCL IS NOW INSTALLED ***"
  1376. X
  1377. END_OF_FILE
  1378. if test 13571 -ne `wc -c <'extended/tclsrc/installTcl.tcl'`; then
  1379.     echo shar: \"'extended/tclsrc/installTcl.tcl'\" unpacked with wrong size!
  1380. fi
  1381. # end of 'extended/tclsrc/installTcl.tcl'
  1382. fi
  1383. echo shar: End of archive 14 \(of 23\).
  1384. cp /dev/null ark14isdone
  1385. MISSING=""
  1386. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 ; do
  1387.     if test ! -f ark${I}isdone ; then
  1388.     MISSING="${MISSING} ${I}"
  1389.     fi
  1390. done
  1391. if test "${MISSING}" = "" ; then
  1392.     echo You have unpacked all 23 archives.
  1393.     echo "Now cd to "extended", edit the makefile, then do a "make""
  1394.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1395. else
  1396.     echo You still need to unpack the following archives:
  1397.     echo "        " ${MISSING}
  1398. fi
  1399. ##  End of shell archive.
  1400. exit 0
  1401.  
  1402. exit 0 # Just in case...
  1403. -- 
  1404. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1405. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1406. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1407. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1408.