user/tinytcl/dos.c

   1 /*
   2  * dos.c --
   3  *
   4  * New DOS functions.
   5  *
   6  * $Id: dos.c,v 1.1.1.1 2001/04/29 20:35:50 karll Exp $
   7  */
   8
   9 #include <stdio.h>
  10 #include <errno.h>
  11 #include <string.h>
  12 #include <stdlib.h>
  13 #include "tcl.h"
  14
  15 #include "tclExtdInt.h"
  16
  17 #include <bios.h>
  18 #include <time.h>
  19
  20 #include <dos.h>
  21 #include <dir.h>
  22 #include <alloc.h>
  23
  24 #include <conio.h>
  25
  26 #ifdef COMPILE_BIOS_MEMSIZE
  27 /* bios_memsize - return the size of memory according to the BIOS */
  28         /* ARGSUSED */
  29 int
  30 cmdbios_memsize(clientData, interp, argc, argv)
  31     ClientData clientData;
  32     Tcl_Interp *interp;
  33     int argc;
  34     char *argv[];
  35 {
  36     long memsize;
  37
  38     if (argc != 1) {
  39         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  40             "\"", (char *) NULL);
  41         return TCL_ERROR;
  42     }
  43     memsize = _bios_memsize() * 1024;
  44
  45     sprintf (interp->result, "%ld", memsize);
  46     return TCL_OK;
  47 }
  48 #endif
  49
  50 /* bios_equiplist - return the equipment list according to the BIOS
  51  *
  52  * This is a very primitive command, probably dating back to the original
  53  * PC.  You can't find out much, and it's all packed into the word that's
  54  * returned.  If you really need this data, this code should be expanded
  55  * to unpack it for you.
  56  */
  57 #ifdef COMPILE_BIOS_EQUIPLIST
  58 int
  59 cmdbios_equiplist(clientData, interp, argc, argv)
  60     ClientData clientData;
  61     Tcl_Interp *interp;
  62     int argc;
  63     char *argv[];
  64 {
  65     if (argc != 1) {
  66         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  67             "\"", (char *) NULL);
  68         return TCL_ERROR;
  69     }
  70     sprintf (interp->result, "%u", _bios_equiplist());
  71     return TCL_OK;
  72 }
  73 #endif
  74
  75 /* kbhit - returns 1 if a key has been hit, else 0 */
  76 int
  77 cmdkbhit(clientData, interp, argc, argv)
  78     ClientData clientData;
  79     Tcl_Interp *interp;
  80     int argc;
  81     char *argv[];
  82 {
  83     if (argc != 1) {
  84         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  85             "\"", (char *) NULL);
  86         return TCL_ERROR;
  87     }
  88     sprintf (interp->result, "%d", kbhit());
  89     return TCL_OK;
  90 }
  91
  92 /* getkey - returns a key as an integer keycode.  waits until a key
  93  * has been pressed.  (So use kbhit to see if one is there first, if you
  94  * don't want to wait.)
  95  */
  96 int
  97 cmdgetkey(clientData, interp, argc, argv)
  98     ClientData clientData;
  99     Tcl_Interp *interp;
 100     int argc;
 101     char *argv[];
 102 {
 103     if (argc != 1) {
 104         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 105             "\"", (char *) NULL);
 106         return TCL_ERROR;
 107     }
 108     sprintf (interp->result, "%d", getch());
 109     return TCL_OK;
 110 }
 111
 112 /* sound frequency - start the sound playing a square wave at the specified
 113  * frequency in hertz.  If 0, stops the sound from playing.
 114  */
 115 int
 116 cmdsound(clientData, interp, argc, argv)
 117     ClientData clientData;
 118     Tcl_Interp *interp;
 119     int argc;
 120     char *argv[];
 121 {
 122     int frequency;
 123
 124     if (argc != 2) {
 125         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 126             " frequency\"", (char *) NULL);
 127         return TCL_ERROR;
 128     }
 129
 130     if (Tcl_GetInt(interp, argv[1], &frequency) != TCL_OK) {
 131         return TCL_ERROR;
 132     }
 133
 134     if (frequency == 0) {
 135         nosound();
 136     } else {
 137         sound(frequency);
 138     }
 139     return TCL_OK;
 140 }
 141
 142 /* getdate - returns the current date as a list containing month, day, year */
 143 int
 144 cmdgetdate(clientData, interp, argc, argv)
 145     ClientData clientData;
 146     Tcl_Interp *interp;
 147     int argc;
 148     char *argv[];
 149 {
 150     struct dosdate_t date;
 151
 152     if (argc != 1) {
 153         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 154             "\"", (char *) NULL);
 155         return TCL_ERROR;
 156     }
 157
 158     _dos_getdate (&date);
 159     sprintf (interp->result,
 160              "%d %d %d",
 161              date.month,
 162              date.day,
 163              date.year);
 164
 165     return TCL_OK;
 166 }
 167
 168 /* setdate month day year -- set the current date to the specified
 169  * month, day and year
 170  */
 171 int
 172 cmdsetdate(clientData, interp, argc, argv)
 173     ClientData clientData;
 174     Tcl_Interp *interp;
 175     int argc;
 176     char *argv[];
 177 {
 178     struct dosdate_t date;
 179     int month;
 180     int day;
 181     int year;
 182
 183     if (argc != 4) {
 184         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 185             " month day year", (char *) NULL);
 186         return TCL_ERROR;
 187     }
 188
 189     if (Tcl_GetInt(interp, argv[1], &month) != TCL_OK) {
 190        return TCL_ERROR;
 191     }
 192
 193     if (Tcl_GetInt(interp, argv[2], &day) != TCL_OK) {
 194        return TCL_ERROR;
 195     }
 196
 197     if (Tcl_GetInt(interp, argv[3], &year) != TCL_OK) {
 198        return TCL_ERROR;
 199     }
 200
 201     date.year = year;
 202     date.day = day;
 203     date.month = month;
 204     date.dayofweek = 0;
 205
 206     if (_dos_setdate (&date) != 0) {
 207         Tcl_AppendResult(interp, "invalid date", (char *) NULL);
 208         return TCL_ERROR;
 209     }
 210
 211     return TCL_OK;
 212 }
 213
 214 /* gettime - returns the current time as a list containing
 215  *           hours, minutes, and seconds
 216  */
 217 int
 218 cmdgettime(clientData, interp, argc, argv)
 219     ClientData clientData;
 220     Tcl_Interp *interp;
 221     int argc;
 222     char *argv[];
 223 {
 224     struct dostime_t time;
 225
 226     if (argc != 1) {
 227         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 228             "\"", (char *) NULL);
 229         return TCL_ERROR;
 230     }
 231
 232     _dos_gettime (&time);
 233     sprintf (interp->result,
 234              "%d %d %d",
 235              time.hour,
 236              time.minute,
 237              time.second);
 238
 239     return TCL_OK;
 240 }
 241
 242 /* settime hour minute second -- set the current time to the specified
 243  * hour, minute and second
 244  */
 245 int
 246 cmdsettime(clientData, interp, argc, argv)
 247     ClientData clientData;
 248     Tcl_Interp *interp;
 249     int argc;
 250     char *argv[];
 251 {
 252     struct dostime_t time;
 253     int hour;
 254     int minute;
 255     int second;
 256
 257     if (argc != 4) {
 258         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 259             " hour minute second", (char *) NULL);
 260         return TCL_ERROR;
 261     }
 262
 263     if (Tcl_GetInt(interp, argv[1], &hour) != TCL_OK) {
 264        return TCL_ERROR;
 265     }
 266
 267     if (Tcl_GetInt(interp, argv[2], &minute) != TCL_OK) {
 268        return TCL_ERROR;
 269     }
 270
 271     if (Tcl_GetInt(interp, argv[3], &second) != TCL_OK) {
 272        return TCL_ERROR;
 273     }
 274
 275     time.hour = hour;
 276     time.minute = minute;
 277     time.second = second;
 278     time.hsecond = 0;
 279
 280     if (_dos_settime (&time) != 0) {
 281         Tcl_AppendResult(interp, "invalid time", (char *) NULL);
 282         return TCL_ERROR;
 283     }
 284
 285     return TCL_OK;
 286 }
 287
 288
 289 /* convert_drive_id letter - converts a drive ID from a letter, like 'a' or
 290  * 'A' to the integer dos uses, where 0 = A, 1 = B, etc.
 291  *
 292  * returns -1 if the ID is invalid, and sets an error message into the
 293  * interpreter result buffer.
 294  */
 295 int
 296 convert_drive_id (Tcl_Interp *interp, char *driveString)
 297 {
 298     char driveChar;
 299     int drive;
 300
 301     driveChar = *driveString;
 302     if ((driveChar == '\0') || (driveString[1] != '\0')) goto bad_drive;
 303     if (isupper(driveChar)) {
 304         drive = driveChar - 'A' + 1;
 305         return drive;
 306     }
 307
 308     if (islower(driveChar)) {
 309         drive = driveChar - 'a' + 1;
 310         return drive;
 311     }
 312
 313   bad_drive:
 314     Tcl_AppendResult(interp, "invalid drive id", (char *) NULL);
 315     return -1;
 316 }
 317
 318 /* diskfree - returns a list containing the free kbytes and the total
 319  * kbytes on the specified drive letter.
 320  *
 321  * Currently this works under a DOS window but not on the handheld.
 322  */
 323 #ifdef COMPILE_DISKFREE
 324 int
 325 cmddiskfree(clientData, interp, argc, argv)
 326     ClientData clientData;
 327     Tcl_Interp *interp;
 328     int argc;
 329     char *argv[];
 330 {
 331     int drive;
 332     struct diskfree_t diskfree;
 333     int kbytesPerCluster;
 334     long freeClusters;
 335     long totalClusters;
 336
 337     if (argc != 2) {
 338         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 339             " drive\"", (char *) NULL);
 340         return TCL_ERROR;
 341     }
 342
 343     if ((drive = convert_drive_id (interp, argv[1])) < 0) {
 344         return TCL_ERROR;
 345     }
 346
 347     if (_dos_getdiskfree (drive, &diskfree) != 0) {
 348         Tcl_AppendResult(interp, "Couldn't get disk space: ",
 349             Tcl_UnixError (interp), (char *) NULL);
 350         return TCL_ERROR;
 351     }
 352
 353     freeClusters = diskfree.avail_clusters;
 354     totalClusters = diskfree.total_clusters;
 355
 356     kbytesPerCluster = (diskfree.bytes_per_sector * diskfree.sectors_per_cluster) / 1024;
 357
 358     sprintf (interp->result,
 359              "%ld %ld",
 360              (long)(freeClusters * kbytesPerCluster),
 361              (long)(totalClusters * kbytesPerCluster));
 362
 363     return TCL_OK;
 364 }
 365 #endif
 366
 367 /* cmdgetfat - returns a list containing the FAT ID byte, sectors per cluster,
 368  * number of clusters, and bytes per sector.
 369  */
 370 #ifdef COMPILE_GETFAT
 371 int
 372 cmdgetfat(clientData, interp, argc, argv)
 373     ClientData clientData;
 374     Tcl_Interp *interp;
 375     int argc;
 376     char *argv[];
 377 {
 378     int drive;
 379     struct fatinfo dtable;
 380     int kbytesPerCluster;
 381     long freeClusters;
 382     long totalClusters;
 383
 384     if (argc != 2) {
 385         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 386             " drive\"", (char *) NULL);
 387         return TCL_ERROR;
 388     }
 389
 390     if ((drive = convert_drive_id (interp, argv[1])) < 0) {
 391         return TCL_ERROR;
 392     }
 393
 394     getfat (drive, &dtable);
 395
 396     sprintf (interp->result,
 397              "%u %u %u %u",
 398              dtable.fi_fatid,
 399              dtable.fi_sclus,
 400              dtable.fi_nclus,
 401              dtable.fi_bysec);
 402
 403     return TCL_OK;
 404 }
 405 #endif
 406
 407 /* cmdgetdfree - returns a list containing the available clusters, total
 408  * clusters, bytes per sector, and sectors per cluster.
 409  */
 410 int
 411 cmdgetdfree(clientData, interp, argc, argv)
 412     ClientData clientData;
 413     Tcl_Interp *interp;
 414     int argc;
 415     char *argv[];
 416 {
 417     int drive;
 418     struct dfree dtable;
 419
 420     if (argc != 2) {
 421         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 422             " drive\"", (char *) NULL);
 423         return TCL_ERROR;
 424     }
 425
 426     if ((drive = convert_drive_id (interp, argv[1])) < 0) {
 427         return TCL_ERROR;
 428     }
 429
 430     getdfree (drive, &dtable);
 431
 432     sprintf (interp->result,
 433              "%u %u %u %u",
 434              dtable.df_avail,
 435              dtable.df_total,
 436              dtable.df_bsec,
 437              dtable.df_sclus);
 438
 439     return TCL_OK;
 440 }
 441
 442 /* drive letter - set the current drive to the specified letter */
 443 int
 444 cmddrive(clientData, interp, argc, argv)
 445     ClientData clientData;
 446     Tcl_Interp *interp;
 447     int argc;
 448     char *argv[];
 449 {
 450     unsigned drive;
 451     unsigned ndrives;
 452     unsigned newdrive;
 453
 454     if (argc > 2) {
 455         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 456             " ?driveid?\"", (char *) NULL);
 457         return TCL_ERROR;
 458     }
 459
 460     if (argc == 1) {
 461         _dos_getdrive (&drive);
 462         sprintf (interp->result, "%c", drive + 'A' - 1);
 463         return TCL_OK;
 464     }
 465
 466     if ((drive = convert_drive_id (interp, argv[1])) < 0) {
 467         return TCL_ERROR;
 468     }
 469
 470     _dos_setdrive (drive, &ndrives);
 471     _dos_getdrive (&newdrive);
 472
 473     if (drive != newdrive) {
 474         Tcl_AppendResult(interp, "invalid drive id", (char *) NULL);
 475     }
 476     return TCL_OK;
 477 }
 478
 479 /* memfree - returns the amount of RAM left on the system */
 480 int
 481 cmdmemfree(clientData, interp, argc, argv)
 482     ClientData clientData;
 483     Tcl_Interp *interp;
 484     int argc;
 485     char *argv[];
 486 {
 487     sprintf(interp->result, "%lu", farcoreleft ());
 488     return TCL_OK;
 489 }
 490
 491 /* stackfree - returns the amount of stack left on the system */
 492 int
 493 cmdstackfree(clientData, interp, argc, argv)
 494     ClientData clientData;
 495     Tcl_Interp *interp;
 496     int argc;
 497     char *argv[];
 498 {
 499     sprintf(interp->result, "%u", stackavail ());
 500     return TCL_OK;
 501 }
 502
 503 #ifdef COMPILE_BIOS_SERIALCOM
 504 /* bios_serialcom - does serial I/O stuff through the BIOS */
 505 int
 506 cmdbios_serialcom(clientData, interp, argc, argv)
 507     ClientData clientData;
 508     Tcl_Interp *interp;
 509     int argc;
 510     char *argv[];
 511 {
 512     int command;
 513     int port;
 514     int data = 0;
 515     int needData = 0;
 516     char *s;
 517
 518     if (argc < 3 || argc > 4) {
 519       argcount:
 520         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 521             " command port (data)\"", (char *) NULL);
 522         return TCL_ERROR;
 523     }
 524
 525     if (STREQU (argv[1], "status")) {
 526         command = _COM_STATUS;
 527         if (argc != 3) goto argcount;
 528     } else if (STREQU (argv[1], "receive")) {
 529         command = _COM_RECEIVE;
 530         if (argc != 3) goto argcount;
 531     } else if (STREQU (argv[1], "send")) {
 532         command = _COM_SEND;
 533         if (argc != 4) goto argcount;
 534
 535         if (Tcl_GetInt(interp, argv[2], &port) != TCL_OK) {
 536             return TCL_ERROR;
 537         }
 538
 539         for (s = argv[3]; *s != '\0'; s++) {
 540             _bios_serialcom (command, port, *s);
 541         }
 542
 543         return TCL_OK;
 544     } else if (STREQU (argv[1], "init")) {
 545         command = _COM_INIT;
 546         if (argc == 3) {
 547             data = (_COM_9600|_COM_NOPARITY|_COM_CHR8|_COM_STOP1);
 548         } else {
 549             if (argc != 4) goto argcount;
 550             needData = 1;
 551         }
 552     } else {
 553         Tcl_AppendResult(interp, "bad arg: ", argv[0],
 554             " command must be one of \"init\", \"send\", \"receive\" or \"status\"", (char *) NULL);
 555         return TCL_ERROR;
 556     }
 557
 558     if (Tcl_GetInt(interp, argv[2], &port) != TCL_OK) {
 559         return TCL_ERROR;
 560     }
 561
 562     if (needData && Tcl_GetInt(interp, argv[3], &data) != TCL_OK) {
 563         return TCL_ERROR;
 564     }
 565
 566     sprintf (interp->result, "%u", _bios_serialcom (command, port, data));
 567     return TCL_OK;
 568 }
 569 #endif
 570
 571 /* rawclock - returns the raw clock value in ticks */
 572 int
 573 cmdrawclock(clientData, interp, argc, argv)
 574     ClientData clientData;
 575     Tcl_Interp *interp;
 576     int argc;
 577     char *argv[];
 578 {
 579     if (argc != 1) {
 580         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 581             "\"", (char *) NULL);
 582         return TCL_ERROR;
 583     }
 584     sprintf (interp->result, "%lu", clock());
 585     return TCL_OK;
 586 }
 587
 588 /* getverify - returns the operating system verify flag.  If 0, writes are
 589  * not being verified.  If 1, they are.
 590  */
 591 #ifdef COMPILE_GETVERIFY
 592 int
 593 cmdgetverify(clientData, interp, argc, argv)
 594     ClientData clientData;
 595     Tcl_Interp *interp;
 596     int argc;
 597     char *argv[];
 598 {
 599     if (argc != 1) {
 600         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 601             "\"", (char *) NULL);
 602         return TCL_ERROR;
 603     }
 604     sprintf (interp->result, "%d", getverify());
 605     return TCL_OK;
 606 }
 607 #endif
 608
 609 /* wait ms - wait the specified number of milliseconds */
 610 int
 611 cmdwait(clientData, interp, argc, argv)
 612     ClientData clientData;
 613     Tcl_Interp *interp;
 614     int argc;
 615     char *argv[];
 616 {
 617     int milliseconds;
 618
 619     if (argc != 2) {
 620         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 621             " milliseconds\"", (char *) NULL);
 622         return TCL_ERROR;
 623     }
 624
 625     if (Tcl_GetInt(interp, argv[1], &milliseconds) != TCL_OK) {
 626         return TCL_ERROR;
 627     }
 628
 629     delay ((unsigned)milliseconds);
 630     return TCL_OK;
 631 }
 632
 633 /* gotoxy - address the cursor to the specified x and y location */
 634 int
 635 cmdgotoxy(clientData, interp, argc, argv)
 636     ClientData clientData;
 637     Tcl_Interp *interp;
 638     int argc;
 639     char *argv[];
 640 {
 641     int x;
 642     int y;
 643
 644     if (argc != 3) {
 645         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 646             " x y\"", (char *) NULL);
 647         return TCL_ERROR;
 648     }
 649
 650     if (Tcl_GetInt(interp, argv[1], &x) != TCL_OK) {
 651         return TCL_ERROR;
 652     }
 653
 654     if (Tcl_GetInt(interp, argv[2], &y) != TCL_OK) {
 655         return TCL_ERROR;
 656     }
 657
 658     gotoxy (x, y);
 659     return TCL_OK;
 660 }
 661
 662 /* clrscr - clear the screen */
 663 int
 664 cmdclrscr(clientData, interp, argc, argv)
 665     ClientData clientData;
 666     Tcl_Interp *interp;
 667     int argc;
 668     char *argv[];
 669 {
 670     int x;
 671     int y;
 672
 673     if (argc != 1) {
 674         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 675             "\"", (char *) NULL);
 676         return TCL_ERROR;
 677     }
 678
 679     clrscr ();
 680     return TCL_OK;
 681 }
 682
 683 /* heapcheck - check the heap for corruption */
 684 int
 685 cmdheapcheck(clientData, interp, argc, argv)
 686     ClientData clientData;
 687     Tcl_Interp *interp;
 688     int argc;
 689     char *argv[];
 690 {
 691     int x;
 692     int y;
 693
 694     if (argc != 1) {
 695         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 696             "\"", (char *) NULL);
 697         return TCL_ERROR;
 698     }
 699
 700       switch( heapcheck () )
 701       {
 702          case _HEAPCORRUPT:
 703               panic( "Memory heap corrupted." );
 704               break;
 705
 706          case _HEAPEMPTY:
 707               panic( "No memory heap." );
 708               break;
 709
 710          case _HEAPOK:
 711              return TCL_OK;
 712
 713          default:
 714               printf( "Unknown error in memory heap." );
 715               break;
 716       }
 717 }
 718
 719 /* mkdir dir - create a directory */
 720 int
 721 cmdmkdir(clientData, interp, argc, argv)
 722     ClientData clientData;
 723     Tcl_Interp *interp;
 724     int argc;
 725     char *argv[];
 726 {
 727     if (argc != 2) {
 728         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 729             " dirname\"", (char *) NULL);
 730         return TCL_ERROR;
 731     }
 732
 733     if (mkdir (argv[1]) < 0) {
 734         Tcl_AppendResult(interp, "Couldn't make directory: ", argv[1], ": ",
 735             Tcl_UnixError (interp), (char *) NULL);
 736         return TCL_ERROR;
 737     }
 738
 739     return TCL_OK;
 740 }
 741
 742 /* unlink file - delete a file */
 743 int
 744 cmdunlink(clientData, interp, argc, argv)
 745     ClientData clientData;
 746     Tcl_Interp *interp;
 747     int argc;
 748     char *argv[];
 749 {
 750     if (argc != 2) {
 751         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 752             " filename\"", (char *) NULL);
 753         return TCL_ERROR;
 754     }
 755
 756     if (unlink (argv[1]) < 0) {
 757         Tcl_AppendResult(interp, "Couldn't unlink file: ", argv[1], ": ",
 758             Tcl_UnixError (interp), (char *) NULL);
 759         return TCL_ERROR;
 760     }
 761
 762     return TCL_OK;
 763 }
 764
 765
 766 /* execvp -- terminate the current process and execute a new one */
 767 int
 768 cmdexecvp(clientData, interp, argc, argv)
 769     ClientData clientData;
 770     Tcl_Interp *interp;
 771     int argc;
 772     char *argv[];
 773 {
 774     if (argc < 2) {
 775         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 776             " command ?args?\"", (char *) NULL);
 777         return TCL_ERROR;
 778     }
 779
 780     if (execvp (argv[1], &argv[1]) < 0) {
 781         Tcl_AppendResult(interp, "Couldn't execvp: ", argv[1], ": ",
 782             Tcl_UnixError (interp), (char *) NULL);
 783         return TCL_ERROR;
 784     }
 785
 786     /* Actually we should not ever get here.  If the execvp succeeds,
 787      * we terminate.
 788      */
 789
 790     return TCL_OK;
 791 }
 792
 793
 794 /*
 795 video normal
 796 video dim
 797 video bright
 798
 799 video write data
 800
 801 video goto x y
 802
 803 video bgcolor n
 804 video color n
 805 video color n blink
 806
 807 normvideo
 808 lowvideo
 809 highvideo
 810 textbackground
 811 textcolor
 812
 813 textbackground(0-7)
 814 0       black
 815 1       blue
 816 2       green
 817 3       cyan
 818 4       red
 819 5       magenta
 820 6       brown
 821 7       lightgray
 822
 823 textcolor(0-15, +128 = blink)
 824 same as above, plus
 825 8       darkgray
 826 9       lightblue
 827 10      lightgreen
 828 11      lightcyan
 829 12      lightred
 830 13      lightmagenta
 831 14      yellow
 832 15      white
 833
 834 wherex - get horizontal cursor position
 835 wherey - get vertical cursor position
 836
 837
 838 */
 839 /* video - do stuff to the video */
 840 int
 841 cmdvideo(clientData, interp, argc, argv)
 842     ClientData clientData;
 843     Tcl_Interp *interp;
 844     int argc;
 845     char *argv[];
 846 {
 847     int color;
 848     int blink;
 849     extern int _directvideo;
 850     int x;
 851     int y;
 852
 853
 854     if (argc < 2) {
 855       argcount:
 856         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 857             " subcommand ?options?\"", (char *) NULL);
 858         return TCL_ERROR;
 859     }
 860
 861     if (STREQU (argv[1], "write")) {
 862         if (argc != 3) {
 863             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 864                 " ", argv[1], " data\"", (char *) NULL);
 865             return TCL_ERROR;
 866         }
 867         cputs (argv[2]);
 868         return TCL_OK;
 869     }
 870
 871     if (STREQU (argv[1], "goto")) {
 872
 873         if (argc != 4) {
 874             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 875                 " ", argv[1], " x y\"", (char *) NULL);
 876             return TCL_ERROR;
 877         }
 878
 879         if (Tcl_GetInt(interp, argv[2], &x) != TCL_OK) {
 880             return TCL_ERROR;
 881         }
 882
 883         if (Tcl_GetInt(interp, argv[3], &y) != TCL_OK) {
 884             return TCL_ERROR;
 885         }
 886
 887         gotoxy (x, y);
 888         return TCL_OK;
 889     }
 890
 891     if (STREQU (argv[1], "normal")) {
 892         if (argc != 2) goto bad2arg;
 893         normvideo();
 894         return TCL_OK;
 895     }
 896
 897     if (STREQU (argv[1], "dim")) {
 898         if (argc != 2) goto bad2arg;
 899         lowvideo ();
 900         return TCL_OK;
 901     }
 902
 903     if (STREQU (argv[1], "bright")) {
 904         if (argc != 2) goto bad2arg;
 905         highvideo ();
 906         return TCL_OK;
 907     }
 908
 909     else if (STREQU (argv[1], "color")) {
 910         if (argc == 3) {
 911             blink = 0;
 912         } else {
 913             if (argc != 4) goto argcount;
 914             blink = 128;
 915         }
 916         if (Tcl_GetInt(interp, argv[2], &color) != TCL_OK) {
 917             return TCL_ERROR;
 918         }
 919
 920         if (color < 0 || color > 15) {
 921             Tcl_AppendResult(interp, "color must be between 0 & 15",
 922             (char *) NULL);
 923             return TCL_ERROR;
 924         }
 925
 926         textcolor (color + blink);
 927         return TCL_OK;
 928     }
 929
 930     if (STREQU (argv[1], "bgcolor")) {
 931         if (argc != 3) goto argcount;
 932
 933         if (Tcl_GetInt(interp, argv[2], &color) != TCL_OK) {
 934             return TCL_ERROR;
 935         }
 936
 937         if (color < 0 || color > 7) {
 938             Tcl_AppendResult(interp, "bgcolor must be between 0 & 7",
 939             (char *) NULL);
 940             return TCL_ERROR;
 941         }
 942
 943         textbackground (color + blink);
 944         return TCL_OK;
 945     }
 946
 947     if (STREQU (argv[1], "clear")) {
 948         if (argc != 2) {
 949           bad2arg:
 950             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 951             " ", argv[1], "\"", (char *) NULL);
 952             return TCL_ERROR;
 953         }
 954
 955         clrscr ();
 956         return TCL_OK;
 957     }
 958
 959     if (STREQU (argv[1], "direct")) {
 960         int directvideo;
 961
 962         if (argc == 2) {
 963             sprintf (interp->result, "%d", _directvideo);
 964             return TCL_OK;
 965         }
 966         if (argc > 3) goto argcount;
 967
 968         if (Tcl_GetInt(interp, argv[2], &directvideo) != TCL_OK) {
 969             return TCL_ERROR;
 970         }
 971         _directvideo = directvideo;
 972         return TCL_OK;
 973     }
 974
 975     Tcl_AppendResult(interp, "bad arg: ", argv[0],
 976         " subcommand must be one of \"data\", \"goto\", \"clear\", \"normal\", \"dim\", \"bright\", \"color\" or \"bgcolor\"", (char *) NULL);
 977         return TCL_ERROR;
 978 }
 979
 980
 981
 982 /* Tcl_InitDos - add all of the DOS functions defined in this file to the
 983  * specified interpreter.
 984  */
 985 int
 986 Tcl_InitDos (Tcl_Interp *interp)
 987 {
 988
 989 #ifdef COMPILE_BIOS_MEMSIZE
 990     Tcl_CreateCommand(interp, "bios_memsize", cmdbios_memsize, (ClientData) 0,
 991             (Tcl_CmdDeleteProc *) NULL);
 992 #endif
 993
 994 #ifdef COMPILE_BIOS_EQUIPLIST
 995     Tcl_CreateCommand(interp, "bios_equiplist", cmdbios_equiplist,
 996             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
 997 #endif
 998
 999 #ifdef COMPILE_BIOS_SERIALCOM
1000     Tcl_CreateCommand(interp, "com", cmdbios_serialcom, (ClientData) 0,
1001             (Tcl_CmdDeleteProc *) NULL);
1002 #endif
1003
1004     Tcl_CreateCommand(interp, "kbhit", cmdkbhit, (ClientData) 0,
1005             (Tcl_CmdDeleteProc *) NULL);
1006     Tcl_CreateCommand(interp, "getkey", cmdgetkey, (ClientData) 0,
1007             (Tcl_CmdDeleteProc *) NULL);
1008     Tcl_CreateCommand(interp, "sound", cmdsound, (ClientData) 0,
1009             (Tcl_CmdDeleteProc *) NULL);
1010     Tcl_CreateCommand(interp, "rawclock", cmdrawclock, (ClientData) 0,
1011             (Tcl_CmdDeleteProc *) NULL);
1012     Tcl_CreateCommand(interp, "getdate", cmdgetdate, (ClientData) 0,
1013             (Tcl_CmdDeleteProc *) NULL);
1014     Tcl_CreateCommand(interp, "setdate", cmdsetdate, (ClientData) 0,
1015             (Tcl_CmdDeleteProc *) NULL);
1016     Tcl_CreateCommand(interp, "gettime", cmdgettime, (ClientData) 0,
1017             (Tcl_CmdDeleteProc *) NULL);
1018     Tcl_CreateCommand(interp, "settime", cmdsettime, (ClientData) 0,
1019             (Tcl_CmdDeleteProc *) NULL);
1020
1021 #ifdef COMPILE_DISKFREE
1022     Tcl_CreateCommand(interp, "diskfree", cmddiskfree, (ClientData) 0,
1023             (Tcl_CmdDeleteProc *) NULL);
1024 #endif
1025
1026 #ifdef COMPILE_GETFAT
1027     Tcl_CreateCommand(interp, "getfat", cmdgetfat, (ClientData) 0,
1028             (Tcl_CmdDeleteProc *) NULL);
1029 #endif
1030
1031     Tcl_CreateCommand(interp, "getdfree", cmdgetdfree, (ClientData) 0,
1032             (Tcl_CmdDeleteProc *) NULL);
1033     Tcl_CreateCommand(interp, "drive", cmddrive, (ClientData) 0,
1034             (Tcl_CmdDeleteProc *) NULL);
1035     Tcl_CreateCommand(interp, "memfree", cmdmemfree, (ClientData) 0,
1036             (Tcl_CmdDeleteProc *) NULL);
1037     Tcl_CreateCommand(interp, "stackfree", cmdstackfree, (ClientData) 0,
1038             (Tcl_CmdDeleteProc *) NULL);
1039     Tcl_CreateCommand(interp, "wait", cmdwait, (ClientData) 0,
1040             (Tcl_CmdDeleteProc *) NULL);
1041     Tcl_CreateCommand(interp, "gotoxy", cmdgotoxy, (ClientData) 0,
1042             (Tcl_CmdDeleteProc *) NULL);
1043     Tcl_CreateCommand(interp, "cls", cmdclrscr, (ClientData) 0,
1044             (Tcl_CmdDeleteProc *) NULL);
1045
1046 #ifdef COMPILE_GETVERIFY
1047     Tcl_CreateCommand(interp, "getverify", cmdgetverify, (ClientData) 0,
1048             (Tcl_CmdDeleteProc *) NULL);
1049 #endif
1050
1051     Tcl_CreateCommand(interp, "heapcheck", cmdheapcheck, (ClientData) 0,
1052             (Tcl_CmdDeleteProc *) NULL);
1053     Tcl_CreateCommand(interp, "mkdir", cmdmkdir, (ClientData) 0,
1054             (Tcl_CmdDeleteProc *) NULL);
1055     Tcl_CreateCommand(interp, "unlink", cmdunlink, (ClientData) 0,
1056             (Tcl_CmdDeleteProc *) NULL);
1057     Tcl_CreateCommand(interp, "execvp", cmdexecvp, (ClientData) 0,
1058             (Tcl_CmdDeleteProc *) NULL);
1059     Tcl_CreateCommand(interp, "video", cmdvideo, (ClientData) 0,
1060             (Tcl_CmdDeleteProc *) NULL);
1061
1062     return TCL_OK;
1063 }
1064