home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Basic / Samples / VIEWMEM / VIEWMEM.ZIP / VIEWMEM.BAS < prev    next >
Encoding:
BASIC Source File  |  1994-02-19  |  9.6 KB  |  383 lines
  1. 'Viewmem V1.0 - Window into Memory
  2. 'PowerBASIC 3.0 Source Code
  3. '(C) Copyright 1993 by Tim Gerchmez
  4. 'All Rights Reserved.
  5.  
  6. 'This program is freeware.  It may be freely
  7. 'copied and distributed, but I retain the copyright.
  8. 'Questions or comments can be addressed to:
  9.  
  10. 'Tim Gerchmez, 12648 S.E. 81st Pl.  Renton, WA  98056
  11.  
  12. $COMPILE EXE
  13.  
  14. shared clr%, bckg%, statclr%, statbckg%,satr??
  15. shared segment??,offset??,aas%,satr1??,satr2??
  16. shared scrnarray??()
  17.  
  18. def fnmyhex$(value??)=right$("000"+hex$(value??),4)
  19. def fnshorthex$(value?)=right$("0"+hex$(value?),2)
  20. dim absolute scrnarray??(1:2000) at vidseg&
  21.  
  22. defcols:
  23. if vidseg&=&hb800 then
  24.     clr%=14:bckg%=0
  25.     statclr%=15:statbckg%=1
  26.     hlclr%=15
  27. else
  28.     clr%=7:bckg%=0
  29.     statclr%=0:statbckg%=7
  30.     hlclr%=15
  31. end if
  32.  
  33. startpoint:
  34. satr??=(16*bckg%+clr%)*256
  35. color clr%,bckg%:cls:call statuslines
  36.  
  37. tloop:
  38. call doscreen
  39. a$=inkey$:if a$="" then goto tloop
  40. if a$=chr$(27) then color 7,0:cls:end
  41. if a$=chr$(0)+chr$(80) then
  42.     incr offset??,80
  43.     call statuslines
  44.     goto tloop
  45. end if
  46. if a$=chr$(0)+chr$(72) then
  47.     decr offset??,80
  48.     call statuslines
  49.     goto tloop
  50. end if
  51. if a$=chr$(0)+chr$(77) then
  52.     incr offset??,1
  53.     call statuslines
  54.     goto tloop
  55. end if
  56. if a$=chr$(0)+chr$(75) then
  57.     decr offset??,1
  58.     call statuslines
  59.     goto tloop
  60. end if
  61. if a$=chr$(0)+chr$(71) and offset??<>0 then
  62.     offset??=0
  63.     call statuslines
  64.     goto tloop
  65. end if
  66. if a$=chr$(0)+chr$(71) then
  67.     segment??=0
  68.     offset??=0
  69.     call statuslines
  70.     goto tloop
  71. end if
  72. if a$=chr$(0)+chr$(79) and offset??<>63696 then
  73.     offset??=&HF8D0
  74.     call statuslines
  75.     goto tloop
  76. end if
  77. if a$=chr$(0)+chr$(79) then
  78.     segment??=&HF000
  79.     offset??=&HF8D0
  80.     call statuslines
  81.     goto tloop
  82. end if
  83. if a$=chr$(0)+chr$(81) then
  84.     incr offset??,1840
  85.     call statuslines
  86.     goto tloop
  87. end if
  88. if a$=chr$(0)+chr$(73) then
  89.     decr offset??,1840
  90.     call statuslines
  91.     goto tloop
  92. end if
  93. if a$="+" or a$="=" then
  94.     incr segment??,&h1000
  95.     call statuslines
  96.     goto tloop
  97. end if
  98. if a$="-" or a$="_" then
  99.     decr segment??,&h1000
  100.     call statuslines
  101.     goto tloop
  102. end if
  103. if lcase$(a$)="j" then
  104.     call clear25
  105.     call capson
  106.     print "Jump To (XXXX) OR (XXXX:XXXX): ";
  107.     call lineinput(9,ja$)
  108.     if len(ja$)=4 then
  109.         offset??=hex2dec&(ja$)
  110.         call statuslines
  111.         call capsoff
  112.         goto tloop
  113.     end if
  114.     if len(ja$)<>9 then call capsoff:call statuslines:goto tloop
  115.     ha$=left$(ja$,4):hb$=right$(ja$,4)
  116.     segment??=hex2dec&(ha$)
  117.     offset??=hex2dec&(hb$)
  118.     call statuslines
  119.     call capsoff
  120.     goto tloop
  121. end if
  122. if lcase$(a$)="a" then
  123.     aas%=1-aas%
  124.     call statuslines
  125.     goto tloop
  126. end if
  127. if lcase$(a$)="d" then
  128.     call clear25
  129.     print "Dump to Disk - Filename: ";
  130.     call lineinput(48,ln$)
  131.     if ln$="" then call statuslines:goto tloop
  132.     on error goto diskerr
  133.     open "o",#1,ln$
  134.     reg 1,&h40*256:reg 2,fileattr(1,2)
  135.     q&=65536-offset??:if q&>65535 then q&=65535
  136.     reg 3,q&:reg 4,offset??:reg 8,segment??
  137.     call interrupt(&h21)
  138.     close #1
  139.     call statuslines:goto tloop
  140. end if
  141. if lcase$(a$)="f" then
  142.     casesens%=1
  143.     call clear25
  144.     print "Find (Case-Sensitive): ";
  145.     goto mainsearchpoint
  146. end if
  147. if lcase$(a$)="s" then
  148.     casesens%=0
  149.     call clear25
  150.     print "Search for: ";
  151.  
  152. mainsearchpoint:
  153.     call lineinput(48,ln$):if ln$="" then call statuslines:goto tloop
  154.     if casesens%=0 then ln$=ucase$(ln$)
  155.     call clear25:print "Searching... ";:locate,,0
  156.         def seg = segment??
  157.         locate 25,14:print fnmyhex$(segment??);":";
  158.         for ofst??=offset?? to (&hffff-len(ln$))
  159.             if inkey$=chr$(27) then
  160.                 def seg
  161.                 call statuslines
  162.                 goto tloop
  163.             end if
  164.             locate 25,19:print fnmyhex$(ofst??);
  165.             s$=""
  166.             for t%=0 to len(ln$)-1
  167.                 s$=s$+chr$(peek(ofst??+t%))
  168.             next t%
  169.             if casesens%=0 then s$=ucase$(s$)
  170.             if s$=ln$ then
  171.                 lastofs??=ofst??
  172.                 offset??=ofst??
  173.                 call doscreen
  174.                 call statuslines
  175.                 call clear25:print "FOUND ";chr$(34);ln$;chr$(34);
  176.                 beep
  177.                 def seg
  178.                 while inkey$<>"":wend
  179.                 sleep
  180.                 a$=inkey$
  181.                 call statuslines
  182.                 goto tloop
  183.             end if
  184.         next ofst??
  185.     def seg
  186.     call clear25
  187.     beep
  188.     print chr$(34);ln$;chr$(34);" Not Found.";
  189.     while inkey$<>"":wend
  190.     def seg
  191.     sleep
  192.     a$=inkey$
  193.     call statuslines
  194.     goto tloop
  195. end if
  196.  
  197. if a$=chr$(0)+chr$(59) then
  198.     color statclr%,statbckg%:cls
  199.     locate 2,25:print "ViewMem Core Memory Utility"
  200.     locate 3,25:print "---------------------------"
  201.     locate 4,22:print "(C) Copyright 1993 by Tim Gerchmez"
  202.     locate 5,29:print "All Rights Reserved."
  203.     locate 8,4:print  "F1 = Help                 F2 = Character Color       F3 = Background Color"
  204.     locate 9,4:print  "F4 = Status Line Foregd.  F5 = Status Line Backgd.   F6 = Default Colors "
  205.     locate 11,4:print "Crsr Up  = Offset - 80    Crsr Lft   = Offset - 1    PgUp = Offset - 1840"
  206.     locate 12,4:print "Crsr Dwn = Offset + 80    Crsr Right = Offset + 1    PgDwn= Offset + 1840"
  207.     locate 14,4:print "Home = Start of Segment / First Segment          + = Forward One Segment"
  208.     locate 15,4:print "End  = End of Segment / Last Segment             - = Backward One Segment"
  209.     locate 17,4:print "A = Toggle All/ASCII display    D = Dump Segment to Disk"
  210.     locate 18,4:print "F = Find (Case-Sensitive)       J = Jump to Offset or Segment/Offset"
  211.     locate 19,4:print "S = Search (Not Case-Sensitive)"
  212.     locate 21,4:print "ESC = Exit Memory View"
  213.  
  214. while inkey$<>"":wend
  215. sleep
  216. a$=inkey$
  217. call statuslines
  218. goto tloop
  219. end if
  220.  
  221. if a$=chr$(0)+chr$(60) then
  222.     incr clr%:if clr%=bckg% then incr clr%
  223.     if clr%>15 then clr%=0:if clr%=bckg% then incr clr%
  224.     goto startpoint
  225. end if
  226. if a$=chr$(0)+chr$(61) then
  227.     incr bckg%:if bckg%=clr% then incr bckg%
  228.     if bckg%>7 then bckg%=0:if bckg%=clr% then incr bckg%
  229.     goto startpoint
  230. end if
  231. if a$=chr$(0)+chr$(62) then
  232.     incr statclr%:if statclr%=statbckg% then incr statclr%
  233.     if statclr%>15 then statclr%=0:if statclr%=statbckg% then incr statclr%
  234.     goto startpoint
  235. end if
  236. if a$=chr$(0)+chr$(63) then
  237.      incr statbckg%:if statbckg%=statclr% then incr statbckg%
  238.      if statbckg%>7 then statbckg%=0:if statbckg%=statclr% then incr statbckg%
  239.      goto startpoint
  240. end if
  241. if a$=chr$(0)+chr$(64) then goto defcols
  242. goto tloop
  243. end
  244.  
  245. diskerr:
  246.     call clear25
  247.     beep
  248.     print "Disk Error ... Press a Key";
  249.     close #1
  250.     while inkey$<>"":wend
  251.     sleep
  252.     a$=inkey$
  253.     call statuslines
  254.     resume tloop
  255.  
  256.  
  257. '------------------------------------------------------------------------------
  258. SUB capsoff
  259.  
  260. 'Turns Capslock off.
  261. 'Example: CALL capsoff
  262.  
  263.     DEF SEG = &H40
  264.     POKE &H17, PEEK(&H17) AND (&HFF - &H40)
  265.     DEF SEG
  266. END SUB
  267.  
  268. '------------------------------------------------------------------------------
  269. SUB capson
  270.  
  271. 'Turns Capslock on.
  272. 'Example: CALL capson
  273.  
  274.     DEF SEG = &H40
  275.     POKE &H17, PEEK(&H17) OR &H40
  276.     DEF SEG
  277. END SUB
  278.  
  279. '------------------------------------------------------------------------------
  280. sub clear25
  281. color statclr%,statbckg%
  282. locate 25,1,0:print space$(79);" ";
  283. locate 25,1,0
  284. end sub
  285.  
  286. '------------------------------------------------------------------------------
  287. sub doscreen
  288. def seg = segment??
  289. sadr??=offset??
  290. for t??=81 to 1920
  291. q?=peek(sadr??)
  292. if aas%=1 then if q?<32 or q?>126 then q?=32
  293. scrnarray??(t??)=satr?? + q?
  294. incr sadr??
  295. next t%
  296. end sub
  297.  
  298. '------------------------------------------------------------------------------
  299. FUNCTION hex2dec& (hxd$)
  300.  
  301. 'Translates a hexidecimal number in a string into a
  302. 'positive decimal number.  Hex digits can be lower or
  303. 'uppercase (won't affect the result).  Up to 7 Hexadecimal
  304. 'digits are allowed.
  305.  
  306. 'Example: PRINT hex2dec& ("&H2A7")
  307.  
  308.     hx$ = UCASE$(hxd$): num& = 0: h$ = "0123456789ABCDEF"
  309.     sm = 1: x& = 0
  310.     IF LEFT$(hx$, 2) = "&H" THEN hx$ = RIGHT$(hx$, LEN(hx$) - 2)
  311.     FOR T% = LEN(hx$) TO 1 STEP -1
  312.         x$ = MID$(hx$, T%, 1)
  313.         FOR u% = 1 TO LEN(h$)
  314.             IF x$ = MID$(h$, u%, 1) THEN EXIT FOR
  315.         NEXT u%
  316.         x% = u% - 1
  317.         x& = x& + (x% * sm): sm = sm * 16
  318.     NEXT T%
  319.     hex2dec& = x&
  320.  
  321. END FUNCTION
  322.  
  323. '------------------------------------------------------------------------------
  324. SUB lineinput (maxlen%, ln$)
  325.  
  326. 'Allows input of a line of text at a certain screen position and a given
  327. 'maximum length.
  328.  
  329. 'ESC will end the routine with ln$=""
  330. 'ENTER ends routine normally.
  331.  
  332. 'Example: CALL lineinput(1,1,10,ln$): 'inputs LN$ at 1,1 max len 10.
  333.  
  334.     ln$ = ""
  335.     yp% = CSRLIN: xp% = POS(0)
  336.     LOCATE yp%, xp%, 1
  337. keyxloop1:
  338.     a$ = INKEY$: IF a$ = "" THEN GOTO keyxloop1
  339.     IF LEN(a$) > 1 THEN GOTO keyxloop1
  340.     IF a$ = CHR$(27) THEN ln$ = "": GOTO endxroutine
  341.     IF a$ = CHR$(13) THEN LOCATE yp%, xp%, 0: PRINT ln$; : GOTO endxroutine
  342.     IF a$ = CHR$(8) THEN IF LEN(ln$) THEN LOCATE CSRLIN, POS(0) - 1: PRINT " "; : LOCATE CSRLIN, POS(0) - 1: ln$ = LEFT$(ln$, LEN(ln$) - 1): GOTO keyxloop1
  343.     IF a$ = CHR$(8) THEN GOTO keyxloop1
  344.     IF LEN(ln$) < maxlen% THEN PRINT a$; : ln$ = ln$ + a$: GOTO keyxloop1
  345.     GOTO keyxloop1
  346. endxroutine:
  347.     LOCATE yp%, xp%
  348.     END SUB
  349.  
  350. '------------------------------------------------------------------------------
  351. sub statuslines
  352.  
  353. locate 1,1,0:color statclr%,statbckg%
  354. print space$(79);" ";
  355. locate 25,1:print space$(79);" ";
  356. locate 1,1:print chr$(25);" ";
  357. a$=fnmyhex$(segment??)
  358. b$=fnmyhex$(offset??)
  359. print a$;":";b$;"  ";
  360. if aas%=0 then print "ALL  "; else print "ASCII  ";
  361. def seg = segment??:q%=peek(offset??):r%=q%:incr r%
  362. locate 25,1:print "ViewMem (C) Copyright 1993 by Tim Gerchmez";chr$(179);
  363. print CHR$(24) + CHR$(25) + CHR$(27) + CHR$(26);
  364.     print "  PgUp  PgDn  F1=Help  ESC=Exit";
  365.     while pos(0)<79:print " ";:wend:print " ";
  366.     color clr%,bckg%
  367. end sub
  368.  
  369. '------------------------------------------------------------------------------
  370. FUNCTION vidseg& public
  371.  
  372. 'Finds Video Segment - Returns
  373. '&Hb800 for Color or &hb000 for Mono.
  374.  
  375. reg 1, (&HF * 256)
  376. CALL INTERRUPT(&H10)
  377. ah = INT(reg(1) / 256): al = reg(1) MOD 256
  378. segment& = &HB800
  379. IF al = &H7 THEN segment& = &HB000
  380. vidseg& = segment&
  381.  
  382. END FUNCTION
  383.