Tcl Source Code

Check-in [e61a1add32]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:enhanced tclsh syntax (rich command line for applications using Tcl_Main without startup-script): try `tclsh -h` for usage; supported -c (command), -i (interactive mode), etc; cherry picked from sebres tclSE; also note https://wiki.tcl.tk/55434 for pure tcl-solution (as init.tcl inject).
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | sebres-rich-cmd-line
Files: files | file ages | folders
SHA3-256:e61a1add3236d09cd6e521c08f201ba58e74bc6036bf66dc02d636d334e412e0
User & Date: sebres 2018-07-26 10:47:16
Context
2018-07-26
10:47
enhanced tclsh syntax (rich command line for applications using Tcl_Main without startup-script): tr... Leaf check-in: e61a1add32 user: sebres tags: sebres-rich-cmd-line
2018-07-12
14:17
win: closes [3f7af0e21e13f1f5] - avoid "permissions denied" by `file delete`, if file stat (TclpObjS... check-in: 4af9ff473e user: sebres tags: core-8-5-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclMain.c.

333
334
335
336
337
338
339
340

341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361


362
363

364
365
366
367
368

369
370











371

372
373
374

























































375

376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
...
405
406
407
408
409
410
411

412
413
414
415
416
417
418
419
...
422
423
424
425
426
427
428
429
430
431












432
433
434
435
436
437
438
439
440
441
442
443
444



445
446
447
448
449
450
451
...
456
457
458
459
460
461
462















463
464





465
466
467
468
469
470
471
    int argc,			/* Number of arguments. */
    char **argv,		/* Array of argument strings. */
    Tcl_AppInitProc *appInitProc)
				/* Application-specific initialization
				 * function to call after most initialization
				 * but before starting to execute commands. */
{
    Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL;

    CONST char *encodingName = NULL;
    PromptType prompt = PROMPT_START;
    int code, length, tty, exitCode = 0;
    Tcl_Channel inChannel, outChannel, errChannel;
    Tcl_Interp *interp;
    Tcl_DString appName;

    interp = Tcl_CreateInterp();
    TclpSetInitialEncodings();
    TclpFindExecutable(argv[0]);

    Tcl_InitMemory(interp);

    /*
     * If the application has not already set a startup script, parse the
     * first few command line arguments to determine the script path and
     * encoding.
     */

    if (NULL == Tcl_GetStartupScript(NULL)) {



	/*
	 * Check whether first 3 args (argv[1] - argv[3]) look like

	 * 	-encoding ENCODING FILENAME
	 * or like
	 * 	FILENAME
	 */


	if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
		&& ('-' != argv[3][0])) {











	    Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);

	    argc -= 3;
	    argv += 3;
	} else if ((argc > 1) && ('-' != argv[1][0])) {

























































	    Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);

	    argc--;
	    argv++;
	}
    }

    path = Tcl_GetStartupScript(&encodingName);
    if (path == NULL) {
	Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
    } else {
	CONST char *pathName = Tcl_GetStringFromObj(path, &length);
	Tcl_ExternalToUtfDString(NULL, pathName, length, &appName);
	path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
	Tcl_SetStartupScript(path, encodingName);
    }
    Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&appName);
    argc--;
    argv++;

    Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);

    argvPtr = Tcl_NewListObj(0, NULL);
    while (argc--) {
	Tcl_DString ds;
	Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
................................................................................
    Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);

    /*
     * Set the "tcl_interactive" variable.
     */

    tty = isatty(0);

    Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0",
	    TCL_GLOBAL_ONLY);

    /*
     * Invoke application-specific initialization.
     */

    Tcl_Preserve((ClientData) interp);
................................................................................
	if (errChannel) {
	    Tcl_WriteChars(errChannel,
		    "application-specific initialization failed: ", -1);
	    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
	    Tcl_WriteChars(errChannel, "\n", 1);
	}
    }
    if (Tcl_InterpDeleted(interp)) {
	goto done;
    }












    if (Tcl_LimitExceeded(interp)) {
	goto done;
    }

    /*
     * If a script file was specified then just source that file and quit.
     * Must fetch it again, as the appInitProc might have reset it.
     */

    path = Tcl_GetStartupScript(&encodingName);
    if (path != NULL) {
	code = Tcl_FSEvalFileEx(interp, path, encodingName);
	if (code != TCL_OK) {



	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
	    if (errChannel) {
		Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
		Tcl_Obj *keyPtr, *valuePtr;

		TclNewLiteralStringObj(keyPtr, "-errorinfo");
		Tcl_IncrRefCount(keyPtr);
................................................................................
		    Tcl_WriteObj(errChannel, valuePtr);
		}
		Tcl_WriteChars(errChannel, "\n", 1);
		Tcl_DecrRefCount(options);
	    }
	    exitCode = 1;
	}















	goto done;
    }






    /*
     * We're running interactively. Source a user-specific startup file if the
     * application specified one and if the file exists.
     */

    Tcl_SourceRCFile(interp);







|
>
|

|






|









|
<
>
>

<
>
|
<
<


>
|
|
>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>





|

|








<
<







 







>
|







 







|


>
>
>
>
>
>
>
>
>
>
>
>
|












>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


>
>
>
>
>







333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361

362
363
364

365
366


367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386

387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461


462
463
464
465
466
467
468
...
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
...
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
...
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
    int argc,			/* Number of arguments. */
    char **argv,		/* Array of argument strings. */
    Tcl_AppInitProc *appInitProc)
				/* Application-specific initialization
				 * function to call after most initialization
				 * but before starting to execute commands. */
{
    Tcl_Obj *path, *resultPtr, *argvPtr, 
	*commandPtr = NULL /* given or input script or command */;
    CONST char *argv0 = argv[0], *encodingName = NULL;
    PromptType prompt = PROMPT_START;
    int code, interact = 0, length, tty, exitCode = 0;
    Tcl_Channel inChannel, outChannel, errChannel;
    Tcl_Interp *interp;
    Tcl_DString appName;

    interp = Tcl_CreateInterp();
    TclpSetInitialEncodings();
    TclpFindExecutable(argv0);

    Tcl_InitMemory(interp);

    /*
     * If the application has not already set a startup script, parse the
     * first few command line arguments to determine the script path and
     * encoding.
     */

    path = Tcl_GetStartupScript(&encodingName);

    argv++; argc--;
    if (path == NULL) {
	/*

	 * Check the enhanced syntax:
	 * 	?-c COMMAND? ?-i? ?-encoding ENCODING? ?FILENAME|--? ?args?


	 */

	while (argc) {
	    const char *opt = argv[0];
	#if defined __WIN32__
	    /* /?   - windows usage wrapper (to -h) */
	    if (*opt == '/' && opt[1] == '?' && opt[2] == '\0') {
		opt = "-h";
	    }
	#endif
	    if (*opt != '-') {
	    	break;
	    }
	    if (argc >= 2) {
		/* -c   - execute the script or the command */
		if (commandPtr == NULL && opt[1] == 'c' && opt[2] == '\0') {
		    commandPtr = Tcl_NewStringObj(argv[1], -1);
		    Tcl_IncrRefCount(commandPtr);
		    argc -= 2;
		    argv += 2;

		    continue;
		}
		/* -e   - encoding of the script to source */
		if ( (opt[1] == 'e' && (opt[2] == '\0' || strcmp("-encoding", opt) == 0))
		  || (opt[1] == '-' && strcmp("--encoding", opt) == 0)) {
		    encodingName = argv[1];
		    argc -= 2;
		    argv += 2;
		    continue;
		}
	    }
	    /* -i   - enter interactive mode after executing the command or the script */
	    if ((opt[1] == 'i' && opt[2] == '\0')
		    || (opt[1] == '-' && strcmp("--interactive", opt) == 0)) {
		interact = 1;
		argc--;
		argv++;
		continue;
	    }
	    /* --   - stop arguments processing (and no file), following all are args */
	    if ((opt[1] == '-' && opt[2] == '\0')) {
		argc--;
		argv++;
		goto start;
	    }
	    /* -v   - print version (and exit if not interactive) */
	    if ((opt[1] == 'v' && opt[2] == '\0')
		    || (opt[1] == '-' && strcmp("--version", opt) == 0)) {
		if (commandPtr) {Tcl_DecrRefCount(commandPtr);};
		commandPtr = Tcl_NewStringObj(
		  "::puts [info patchlevel]", -1);
		Tcl_IncrRefCount(commandPtr);
		argc = 0;
		goto start;
	    }
	    /* -h   - print syntax (and exit if not interactive) */
	    if ((opt[1] == 'h' && opt[2] == '\0')
		    || (opt[1] == '-' && strcmp("--help", opt) == 0)) {
		if (commandPtr) {Tcl_DecrRefCount(commandPtr);};
		commandPtr = Tcl_NewStringObj(
		  "::puts \"[file tail $::argv0] ?-c command? ?-i?"
		    " ?-e|--encoding name? ?fileName|--? ?arg arg ...?\n"
		  "[file tail $::argv0] ?-v|--version? ?-h|--help?\";", -1);
		Tcl_IncrRefCount(commandPtr);
		argc = 0;
		goto start;
	    }
	    /* default - unknown argument (filename?) */
	    break;
	}

	/*
	 * Check whether first args look like FILENAME (avoid if starts with '-'
	 * for backwards-compatibility reasons).
	 */

	if ((argc >= 1) && (*argv[0] != '-')) {
	    path = Tcl_NewStringObj(argv[0], -1);
	    Tcl_SetStartupScript(path, encodingName);
	    argc--;
	    argv++;
	}
    }

start:
    if (path == NULL) {
	Tcl_ExternalToUtfDString(NULL, argv0, -1, &appName);
    } else {
	CONST char *pathName = Tcl_GetStringFromObj(path, &length);
	Tcl_ExternalToUtfDString(NULL, pathName, length, &appName);
	path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
	Tcl_SetStartupScript(path, encodingName);
    }
    Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&appName);



    Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);

    argvPtr = Tcl_NewListObj(0, NULL);
    while (argc--) {
	Tcl_DString ds;
	Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
................................................................................
    Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);

    /*
     * Set the "tcl_interactive" variable.
     */

    tty = isatty(0);
    interact |= ((commandPtr == NULL) && (path == NULL) && tty);
    Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, Tcl_NewIntObj(interact),
	    TCL_GLOBAL_ONLY);

    /*
     * Invoke application-specific initialization.
     */

    Tcl_Preserve((ClientData) interp);
................................................................................
	if (errChannel) {
	    Tcl_WriteChars(errChannel,
		    "application-specific initialization failed: ", -1);
	    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
	    Tcl_WriteChars(errChannel, "\n", 1);
	}
    }
    if (Tcl_InterpDeleted(interp) || Tcl_LimitExceeded(interp)) {
	goto done;
    }

    /*
     * If a (pre)script was specified with "-c" then just execute that here.
     */

    if (commandPtr != NULL) {
	code = Tcl_EvalObjEx(interp, commandPtr, 0);
	if (code != TCL_OK) {
	    goto exit_error;
	}
    }

    if (Tcl_InterpDeleted(interp) || Tcl_LimitExceeded(interp)) {
	goto done;
    }

    /*
     * If a script file was specified then just source that file and quit.
     * Must fetch it again, as the appInitProc might have reset it.
     */

    path = Tcl_GetStartupScript(&encodingName);
    if (path != NULL) {
	code = Tcl_FSEvalFileEx(interp, path, encodingName);
	if (code != TCL_OK) {

exit_error:

	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
	    if (errChannel) {
		Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
		Tcl_Obj *keyPtr, *valuePtr;

		TclNewLiteralStringObj(keyPtr, "-errorinfo");
		Tcl_IncrRefCount(keyPtr);
................................................................................
		    Tcl_WriteObj(errChannel, valuePtr);
		}
		Tcl_WriteChars(errChannel, "\n", 1);
		Tcl_DecrRefCount(options);
	    }
	    exitCode = 1;
	}
    }

    /*
     * If not interactive, exit
     */
    if (!interact) {
	if (exitCode == 0 && commandPtr != NULL) {
	    /* output the last result if not empty (enhanced by -c syntax) */
	    Tcl_Obj *res = Tcl_GetObjResult(interp);
	    if (Tcl_GetString(res) && res->length) {
		outChannel = Tcl_GetStdChannel(TCL_STDOUT);
		Tcl_WriteObj(outChannel, res);
		Tcl_WriteChars(outChannel, "\n", 1);
	    }
	}
	goto done;
    }
    exitCode = 0;
    if (commandPtr != NULL) {
	Tcl_DecrRefCount(commandPtr);
	commandPtr = NULL;
    }

    /*
     * We're running interactively. Source a user-specific startup file if the
     * application specified one and if the file exists.
     */

    Tcl_SourceRCFile(interp);