home *** CD-ROM | disk | FTP | other *** search
/ Boston 2 / boston-2.iso / DOS / PROGRAM / BASIC / POWBASIC / LIBRARY3 / APLIB.ZIP / MISC-U.BAS < prev    next >
BASIC Source File  |  1990-11-23  |  15KB  |  541 lines
  1.  
  2. '                      ╔════════════════════════════╗
  3. '                      ║                            ║
  4. '                      ║         MISC_U.BAS         ║
  5. '                      ║                            ║
  6. '                      ║   H.B. LIBRARY LEFTOVERS   ║
  7. '                      ║                            ║
  8. '                      ╚════════════════════════════╝
  9.  
  10.  
  11.                             $COMPILE UNIT
  12.                             $ERROR ALL OFF
  13.  
  14.   %False = 0
  15.   %True = NOT %False
  16.   %FLAGS = 0:  %AX = 1:  %BX = 2:  %CX = 3:  %DX = 4
  17.                          %SI = 5:  %DI = 6:  %BP = 7:  %DS = 8:  %ES = 9
  18.  
  19.  %ResetRodent = 0 '        mouse routine and humor (??) courtesy of Barry Erick
  20.  %ReadRodent = 3
  21.  %CheckScreensSaved = %False
  22.  
  23.  DEFINT A-Z
  24.  
  25.  DECLARE SUB SUPERMENU (string array,integer,integer,integer,string,integer)
  26.  
  27.  EXTERNAL Footer$, CurrLine, LineGroup, Page%, NewRec, KeyField, PullDown
  28.  EXTERNAL OopsBeep$, InitPrt$, FontCode$, NextScrn2Pop, ScrnStackSize
  29.  EXTERNAL ScreenStack$ (), VideoSeg&, OrigL, OrigC,  ReverseLF$, NeedDCon
  30.  EXTERNAL MenuHelpLine$()
  31.  
  32.  
  33. '            _____________________________________________________
  34.  
  35.  
  36. SUB SCREENPUSH PUBLIC
  37.  
  38.  DEF SEG = VideoSeg&
  39.  
  40.  INCR NextScrn2Pop
  41.                               $IF %CheckScreensSaved
  42.  
  43.  FOR N = 1 TO 9: LPRINT ReverseLF$;: NEXT
  44.  LPRINT "SCREEN PUSHED: "; NextScrn2Pop
  45.  FOR N = 1 TO 9: LPRINT: NEXT
  46.                                        $ENDIF
  47.  IF NextScrn2Pop =< ScrnStackSize THEN
  48.    ScreenStack$ (NextScrn2Pop) = PEEK$ (0, 4000)
  49.  ELSE
  50.    BSAVE RD$ + "SCRN_" + LTRIM$(STR$(NextScrn2Pop)), 0, 4000
  51.  END IF
  52.  
  53.  DEF SEG
  54.  END SUB                                                      REM PUSHSCREEN
  55. '            _____________________________________________________
  56.  
  57. SUB SCREENPOP PUBLIC
  58.  DEF SEG = VideoSeg&
  59.                                   $IF %CheckScreensSaved
  60.  FOR N = 1 TO 9: LPRINT ReverseLF$;: NEXT
  61.  LPRINT "                                SCREEN POPPED: "; NextScrn2Pop
  62.  FOR N = 1 TO 9: LPRINT: NEXT
  63.                                             $ENDIF
  64.  IF NextScrn2Pop < 1 THEN
  65.    FOR N = 1 TO 10: LOCATE 2*N, 5*N: PRINT "SCREEN STACK UNDERFLOW": NEXT
  66.  ELSEIF NextScrn2Pop =< ScrnStackSize THEN
  67.    POKE$ 0, ScreenStack$ (NextScrn2Pop)
  68.  ELSE
  69.    BLOAD RD$ + "SCRN_" + LTRIM$(STR$(NextScrn2Pop))
  70.  END IF
  71.  
  72.  DECR NextScrn2Pop
  73.  
  74.  DEF SEG
  75.  END SUB                                                      REM POPSCREEN
  76. '            _____________________________________________________
  77.  
  78.  
  79.  
  80.  
  81. SUB RestoreDOSScreen PUBLIC
  82.  NextScrn2Pop = 1
  83.  CALL SCREENPOP
  84.  LOCATE OrigL, OrigC
  85.  END SUB
  86.  
  87. ' =============================================================================
  88.  
  89.  
  90. SUB PRINTLINE (L$) PUBLIC
  91.  LOCAL NL, I
  92.  
  93.  NL = %PageLength - %TopMargin - %BottomMargin
  94.  IF Footer$ <> "" THEN DECR NL, 2
  95.  IF Header$ <> "" THEN DECR NL, 2
  96.  
  97. '                    line comes in as a passed string. increase line counter ...
  98.  INCR CurrLine
  99.  IF UCASE$ (L$) = "START" THEN
  100.    CurrLine = 1
  101.    Page% = 1
  102.    LPRINT  InitPrt$ + FontCode$;
  103.    FOR I = 1 TO %TopMargin: LPRINT: NEXT
  104.  
  105. '   IF PAGE IS FULL, OR DOESN'T HAVE ROOM FOR LineGroup LINES, PRINT FOOTER ...
  106.  
  107.  ELSEIF CurrLine + LineGroup > NL OR UCASE$ (L$) = "END" THEN
  108.     IF Footer$ <> "" THEN GOSUB PPrintFoot
  109.     INCR Page%: CurrLine = 1: LPRINT CHR$(12)
  110. '                       ... AND IF THERE'S MORE TO PRINT, ALSO A HEADER ...
  111.     IF UCASE$(L$) <> "END" AND Header$ <> "" THEN_
  112.                       FOR I = 1 TO %TopMargin: LPRINT: NEXT: GOSUB PPrintHead
  113.  END IF
  114.  
  115. '                                               NOW PRINT THE LINE AND EXIT
  116.  IF UCASE$(L$) = "END" THEN
  117.    Page% = 0
  118.    LPRINT  InitPrt$;
  119.  ELSEIF UCASE$(L$) <> "START" THEN
  120.    LPRINT L$
  121.  END IF
  122.  EXIT SUB
  123.  
  124. PPrintHead:
  125.    LPRINT Header$;
  126.    IF INSTR (UCASE$ (RIGHT$(Header$,8)), "PAGE") THEN
  127.      LPRINT Page%
  128.    ELSE
  129.      LPRINT
  130.    END IF
  131.    LPRINT: RETURN
  132.  
  133. PPrintFoot:
  134.    LPRINT
  135.    LPRINT Footer$;
  136.    IF INSTR (UCASE$ (RIGHT$(Footer$,8)), "PAGE") THEN
  137.      LPRINT Page%
  138.    ELSE
  139.      LPRINT
  140.    END IF
  141.    RETURN
  142.  
  143.      END SUB                                              REM PRINTLINE
  144.  
  145.  
  146. ' =========================================================================
  147.  
  148.  
  149.  FUNCTION GetFileFunction$ PUBLIC
  150.  
  151.  LOCAL Choice, Title$, Ky%, FileFun$ ()
  152.  DIM DYNAMIC FileFun$ (24)
  153.  
  154.  
  155.  IF NewRec THEN
  156.    IF KeyField THEN GOSUB KeyFldNewRec ELSE GOSUB NonkeyfldNewRec
  157.  ELSE
  158.    IF KeyField THEN GOSUB KeyFldExistRec ELSE GOSUB NonkeyFldExistRec
  159.  END IF
  160.  
  161.  Choice = 1
  162.  
  163.       CALL SCREENPUSH
  164.       CALL SUPERMENU (FileFun$ (), 0, 30, Choice, "FILE FUNCTION", Ky%)
  165.       CALL SCREENPOP
  166.  
  167.  IF Choice = 0 THEN
  168.    GetFileFunction$ = ""
  169.  ELSE
  170.    GetFileFunction$ = LEFT$ (FileFun$(Choice), 1)
  171.  END IF
  172.  
  173.  ERASE FileFun$
  174.  
  175.  EXIT FUNCTION
  176.  
  177. KeyFldNewRec:
  178.  FileFun$(1) = "C CLEAR DATA FIELDS"
  179.  MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
  180.  FileFun$(2) = "F FIND A MATCH"
  181.  MenuHelpLine$(2) = "match entry in this field as closely as possible"
  182.  FileFun$(3) = "S SAVE RECORD"
  183.  MenuHelpLine$(3) = "write data shown into a new record"
  184.  FileFun$(4) = "V VIEW MEMOS"
  185.  MenuHelpLine$(4) = "add extra notes on this entry"
  186.  FileFun$(5) = "D DELETE RECORD"
  187.  MenuHelpLine$(5) = "erase this record"
  188.  FileFun$(6) = "END"
  189.  RETURN
  190.  
  191. KeyFldExistRec:
  192.  FileFun$(1) = "C CLEAR DATA FIELDS"
  193.  MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
  194.  FileFun$(2) = "N NEXT IN ORDER
  195.  MenuHelpLine$(2) = "continue the search forward"
  196.  FileFun$(3) = "P PREVIOUS RECORD"
  197.  MenuHelpLine$(3) = "back up, search in reverse"
  198.  FileFun$(4) = "S SAVE RECORD"
  199.  MenuHelpLine$(4) = "update this record using entries shown"
  200.  FileFun$(5) = "V VIEW MEMOS"
  201.  MenuHelpLine$(5)_
  202.            = "read extra notes on this entry if any; edit / change; or add"
  203.  FileFun$(6) = "D DELETE RECORD"
  204.  MenuHelpLine$(6) = "erase this record"
  205.  FileFun$(7) = "END"
  206.  RETURN
  207.  
  208. NonkeyFldNewRec:
  209.  FileFun$(1) = "C CLEAR DATA FIELDS"
  210.  MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
  211.  FileFun$(2) = "S SAVE RECORD"
  212.  MenuHelpLine$(2) = "write data shown into a new record"
  213.  FileFun$(3) = "D DELETE RECORD"
  214.  MenuHelpLine$(3) = "erase this record"
  215.  FileFun$(4) = "END"
  216.  RETURN
  217.  
  218. NonkeyFldExistRec:
  219.  FileFun$(1) = "C CLEAR DATA FIELDS"
  220.  MenuHelpLine$(1) = "clear all entries in this window, giving a blank record"
  221.  FileFun$(2) = "S SAVE RECORD"
  222.  MenuHelpLine$(2) = "update this record using entries shown
  223.  FileFun$(3) = "V VIEW MEMOS"
  224.  MenuHelpLine$(3) = "read extra notes on this entry if any; edit / change; or add"
  225.  FileFun$(4) = "D DELETE RECORD"
  226.  MenuHelpLine$(4) = "erase this record
  227.  FileFun$(5) = "END"
  228.  RETURN
  229.  
  230.  END FUNCTION
  231.  
  232. '=============================================================================
  233.  
  234.  FUNCTION IsBlank (W$) PUBLIC
  235.    IF RTRIM$ (W$) = "" THEN
  236.      IsBlank = %True
  237.    ELSE
  238.      IsBlank = %False
  239.    END IF
  240.  END FUNCTION
  241.  
  242.  
  243. FUNCTION GetAttr PUBLIC
  244.  DEF SEG = VideoSeg&
  245.  GetAttr = PEEK ((80*CSRLIN-80 + POS - 1) * 2) + 1
  246.  DEF SEG
  247.  END FUNCTION
  248.  
  249.  
  250. FUNCTION IsRodent PUBLIC    '     finds if you have a rodent and also resets it
  251.  REG %AX, %ResetRodent
  252.  CALL INTERRUPT &H33
  253.  IsRodent = REG(%AX) '                                          true if present
  254. END FUNCTION
  255.  
  256.  
  257. SUB Mouse(MV1, MV2, MV3, MV4) PUBLIC
  258.  REG %AX, MV1: REG %BX, MV2: REG %CX, MV3: REG %DX, MV4
  259.  CALL INTERRUPT &H33
  260.  MV1 = REG(%AX): MV2 = REG(%BX): MV3 = REG(%CX): MV4 = REG(%DX)
  261.  
  262. END SUB
  263. ' _________________________________________________________________________
  264.  
  265. FUNCTION MouseClicked PUBLIC
  266.  LOCAL MC, X, Y
  267.  IF NeedDCon THEN
  268.    CALL Mouse (%ReadRodent, MC, X, Y)
  269.    MouseClicked = MC
  270.  ELSE
  271.    MouseClicked = 0
  272.  END IF
  273. END FUNCTION
  274. ' _________________________________________________________________________
  275.  
  276. FUNCTION GetCurrentDrive$ PUBLIC
  277.    REG %AX, &H1900
  278.    CALL INTERRUPT &H21
  279.    GetCurrentDrive$ = CHR$ ((REG (%AX) AND &B00001111) + 65) + ":"
  280.  
  281. END FUNCTION
  282.  
  283. FUNCTION GetCurrentDir$ (Drv$) PUBLIC
  284.    STATIC Dummy$
  285.    Dummy$ = SPACE$ (64)
  286.  
  287.    REG %AX, &H4700
  288.  
  289.    IF Drv$ = "" THEN
  290.      REG %DX, 0 '                                 for default drive
  291.    ELSE
  292.      REG %DX, (ASC(UCASE$(Drv$))-64)
  293.    END IF
  294.  
  295.    REG %DS, STRSEG (Dummy$)
  296.    REG %SI, STRPTR (Dummy$)
  297.  
  298.    CALL INTERRUPT &H21
  299.  
  300.    GetCurrentDir$ = "\" + EXTRACT$ (Dummy$, CHR$(0))
  301.  
  302. END FUNCTION '             ==========================        GetCurrentDir$ ()
  303.  
  304. FUNCTION GetFreeSpace! (Drv$) PUBLIC
  305.    IF Drv$ = "" THEN
  306.      REG %DX, 0 '     for default drive
  307.    ELSE
  308.      REG %DX, (ASC(UCASE$(Drv$))-64)
  309.    END IF
  310.    REG %AX, &H3600  '     dos function number &H36 into AH
  311.    CALL INTERRUPT &H21
  312.    GetFreeSpace! = CSNG (REG(%BX)) * REG (%CX) * REG (%AX)
  313. '                     free clusters  * byt/sect  * sect/cluster
  314.  
  315. END FUNCTION '                    ----------
  316.  
  317. FUNCTION ReadParamFor (A$) PUBLIC ' this reads parameters from the command tail
  318.  LOCAL L, N
  319.  L = INSTR (COMMAND$, A$)
  320.  IF L THEN
  321.    N = VAL ("&H"+MID$ (COMMAND$, L + 5, 2))
  322.    IF N THEN ReadParamFor = N
  323.  END IF
  324.  END FUNCTION '                    ----------
  325.  
  326. SUB ClearLine PUBLIC
  327.  
  328.  LOCAL CLL0, CLC0
  329.  
  330.  CLL0 = CSRLIN
  331.  CLC0 = POS
  332.  PRINT STRING$ ((81-CLC0)," ");    ' this almost fills the line ...
  333.  LOCATE CLL0, CLC0
  334.  
  335.  END SUB '                    ----------  
  336.  
  337. ' ============================================================================
  338.  
  339.  
  340. SUB DirFirst (F$, FileSize&, DateCode&, TimeCode&) PUBLIC
  341.  
  342.  LOCAL DTASeg&, AttrOffset&, FlNOffset&, SearchErr, FlN$, N
  343.  
  344.  FlN$ = F$ + CHR$(0)
  345.  REG %DS, STRSEG (FlN$)
  346.  REG %DX, STRPTR (FlN$)
  347.  REG %CX, &H17
  348.  REG %AX, &H4E00
  349.  CALL INTERRUPT &H21
  350.  SearchErr = REG(%AX)
  351.  IF SearchErr THEN
  352.     F$ = ""
  353.     EXIT SUB
  354.  END IF
  355.  
  356.  REG %AX, &H2F00
  357.  
  358.     CALL INTERRUPT &H21
  359.  
  360.  DTAseg& = REG(%ES)
  361.  AttrOffset& = REG(%BX) + &H15
  362.  FlNOffset& = REG(%BX) + &H1E
  363.  TimeOffset& = REG(%BX) + &H16
  364.  DateOffset& = REG(%BX) + &H18
  365.  SizeOffset& = REG(%BX) + &H1A
  366.  
  367.  FlN$ = ""
  368.  DEF SEG = DTAseg&
  369.  N = 0
  370.  
  371.  DO UNTIL PEEK (FlNOffset& + N) = 0 '          read the ASCIIZ file-name string
  372.    FlN$ = FlN$ + CHR$ (PEEK (FlNOffset& + N))
  373.    INCR N
  374.  LOOP
  375.  
  376.  IF (PEEK(AttrOffset&) AND 16) = 16 THEN '        bracket if a subdirectory
  377.     FlN$ = "<"+FlN$+">"
  378.  END IF
  379.  
  380.  FileSize& = CVL (PEEK$ (SizeOffset&, 4))
  381.  DateCode& =  PEEK (DateOffset&) + &H100 * PEEK (DateOffset& + 1)
  382.  TimeCode& =  PEEK (TimeOffset&) + &H100 * PEEK (TimeOffset& + 1)
  383.  
  384.  DEF SEG
  385.  
  386.  F$ = FlN$
  387.  
  388.  END SUB
  389.  
  390. '                        ===========================
  391.  
  392.  
  393.  
  394.  SUB DirNext (F$, FileSize&, DateCode&, TimeCode&) PUBLIC
  395.  
  396.  LOCAL FlN$, DTAseg&, FlNOffset&, AttrOffset&, N
  397.  
  398.  REG %AX, &H4F00
  399.  CALL INTERRUPT &H21
  400.  IF REG(%AX) = 18 THEN
  401.     F$ = ""
  402.     EXIT SUB
  403.  END IF
  404.  REG %AX, &H2F00
  405.  CALL INTERRUPT &H21
  406.  DTAseg& = REG(%ES)
  407.  AttrOffset& = REG(%BX) + 21
  408.  FlNOffset& = REG(%BX) + &H1E
  409.  TimeOffset& = REG(%BX) + &H16
  410.  DateOffset& = REG(%BX) + &H18
  411.  SizeOffset& = REG(%BX) + &H1A
  412.  
  413.  FlN$ = ""
  414.  DEF SEG = DTAseg&
  415.  
  416.  DO UNTIL PEEK (FlNOffset& + N) = 0
  417.    FlN$ = FlN$ + CHR$(PEEK(FlNOffset& + N))
  418.    INCR N
  419.  LOOP
  420.  
  421.  IF (PEEK(AttrOffset&) AND 16) = 16 THEN
  422.     FlN$ = "<"+FlN$+">" '                  subdirs will come back w/ brackets
  423.  END IF
  424.  
  425.  FileSize& = CVL (PEEK$ (SizeOffset&, 4))
  426.  DateCode& =  PEEK (DateOffset&) + &H100 * PEEK (DateOffset& + 1)
  427.  TimeCode& =  PEEK (TimeOffset&) + &H100 * PEEK (TimeOffset& + 1)
  428.  DEF SEG
  429.  F$ = FlN$
  430.  
  431. END SUB
  432.  
  433. '                   ========================================
  434.  
  435.  
  436. FUNCTION DecodeDate$ (DateCode&) PUBLIC
  437.  LOCAL M, D, Y
  438.  Y = DateCode&\512
  439.  M = (DateCode& MOD 512) \ 32
  440.  D = DateCode& MOD 32
  441.  DecodeDate$ = LTRIM$ (STR$ (M)) + "-" +_
  442.                    STRING$ (1 + (D > 9), "0") + LTRIM$ (STR$ (D)) + "-" +_
  443.                                LTRIM$ (STR$ (Y + 80))
  444.  
  445. END FUNCTION '         ============================      DecodeDate$ ()
  446.  
  447.  
  448. FUNCTION DecodeTime$ (TimeCode&) PUBLIC
  449.  LOCAL H, H24, M
  450.  H24 = INT(TimeCode&\2048)
  451.  IF H24 > 12 THEN
  452.     H = H24 - 12
  453.     pm = %True
  454.  ELSE
  455.     H = H24
  456.     pm = %False
  457.  END IF
  458.  IF H = 0 THEN H = 12
  459.  M = (TimeCode&-(CLNG(H24)*2048))\32
  460.  
  461.  DecodeTime$ = STRING$ (1 + (H > 9), " ") + LTRIM$ (STR$ (H)) + ":" +_
  462.                    STRING$ (1 + (M > 9), "0") + LTRIM$ (STR$ (M)) +_
  463.                                MID$ (" pm am", pm*3+4, 3)
  464. END FUNCTION '         ============================      DecodeTime$ ()
  465.  
  466.  
  467. FUNCTION EXIST (F$) PUBLIC
  468.  
  469.  LOCAL SearchErr, FZ$
  470.  
  471.  REG %AX, &H2F00
  472.  CALL INTERRUPT &H21 '                     GET DOS'S D.T.A.
  473. '                              (in FEXIST.BOX Barry gets out the DTA addr but
  474. '                                 never uses it. It's ES:BX.)
  475.  FZ$ = F$ + CHR$(0)
  476.  REG %DS, STRSEG (FZ$)
  477.  REG %DX, STRPTR (FZ$)
  478.  REG %CX, &H7
  479.  REG %AX, &H4E00
  480.  CALL INTERRUPT &H21
  481.  SearchErr = REG(%AX)
  482.  SELECT CASE SearchErr
  483.    CASE 2, 3, 15, 18
  484.      EXIST = 0
  485.    CASE ELSE
  486.      EXIST = -1
  487.  END SELECT
  488.  DEF SEG
  489.  
  490. END Function '            ==================        EXIST ()
  491.  
  492.  
  493. FUNCTION FQFileSpec$ (A$) PUBLIC
  494.  
  495.  LOCAL CurrentDir$, CurrentDrv$             ' Of course there's a DOS function
  496.  CurrentDrv$ = GetCurrentDrive$             ' that does something like this --
  497.  CurrentDir$ = GetCurrentDir$ ("")          ' maybe exactly this! I never did
  498.                                             ' try it out. So this may be the
  499.  A$ = REMOVE$ (A$, " ")                     ' hard way!
  500.  IF INSTR (A$, ANY "^/,<>+()|"+CHR$(34)) THEN
  501.    FQFileSpec$ = "": EXIT FUNCTION
  502.  END IF
  503.  
  504.  SELECT CASE INSTR (A$, ":")
  505.    CASE 0
  506.      IF INSTR (A$, "\") THEN
  507.        A$ = CurrentDrv$ + A$
  508.      ELSE
  509.        A$ = CurrentDrv$ + CurrentDir$ +"\"+ A$
  510.      END IF
  511.      EXIT SELECT
  512.    CASE 2
  513.      IF INSTR (A$, "\") = %False THEN
  514.        CurrentDir$ = GetCurrentDir$ (LEFT$(A$,1))
  515.      END IF
  516.      EXIT SELECT
  517.    CASE ELSE
  518.      PLAY "O0 C64": FQFileSpec$ = "": EXIT FUNCTION
  519.  END SELECT
  520.  IF INSTR (A$, "\") = %False THEN
  521.    IF RIGHT$ (A$, 1) = ":" THEN
  522.      A$ = A$ + CurrentDir$ + "\"
  523.    ELSEIF CurrentDir$ = "\" THEN
  524.      A$ = LEFT$ (A$, 2) + "\" + MID$ (A$, 3)
  525.    ELSE
  526.      A$ = LEFT$ (A$, 2) + CurrentDir$ + "\" + MID$ (A$, 3)
  527.    END IF
  528.  END IF
  529.  
  530.  IF RIGHT$ (A$, 1) = "\" THEN A$ = A$ + "*.*"
  531.  
  532.  REPLACE "\\" WITH "\" IN A$
  533.  FQFileSpec$ = A$
  534.  
  535. END FUNCTION '                 =========                      FQFileSpec$
  536.  
  537. FUNCTION Cen$ (A$) PUBLIC
  538.   Cen$ = SPACE$ (40 - LEN (A$)\2) + A$
  539. END FUNCTION
  540.  
  541.