home *** CD-ROM | disk | FTP | other *** search
/ PC Underground / UNDERGROUND.ISO / graphic / grabber.pas < prev    next >
Pascal/Delphi Source File  |  1995-07-28  |  11KB  |  272 lines
  1. {$G+}
  2. {$m 1024,0,0}                   {requires little stack and no heap}
  3. Uses ModeXLib,Crt,Dos;
  4.  
  5. Var OldInt9:Pointer;            {pointer to old keyboard handler}
  6.     active:Boolean;             {set, if hard copy already in motion}
  7.     no:Word;                    {Number of picture, for assigning filenames}
  8.     installed:Boolean;          {already installed ?}
  9.  
  10.     Mode,                       {current VGA-Mode: 13h, ffh (Mode X)}
  11.                                 {or 0 (neither of the two}
  12.     Split_at,                   {Split-Line (graphic line}
  13.     LSA,                        {Linear Starting Address}
  14.     Skip:Word;                  {Number of bytes to skip}
  15.  
  16. Procedure GetMode;
  17. {sets current graphic mode 13h or Mode X (No. 255)}
  18. {and frame data (Split-Line, Start address)}
  19. Begin
  20.   Mode:=$13;                    {Mode 13h Standard}
  21.   asm                           {set Bios-Mode}
  22.     mov ax,0f00h                {Function: Video-Info}
  23.     int 10h
  24.     cmp al,13h                  {Bios-Mode 13h set ?}
  25.     je @Bios_ok
  26.     mov mode,0                  {if no -> neither Mode 13h nor X active}
  27.   @bios_ok:
  28.   End;
  29.   If Mode=0 Then Exit;          {wrong mode -> abort}
  30.  
  31.   Port[$3c4]:=4;                {read out TS-Register 4 (Memory Mode)}
  32.   If Port[$3c5] and 8 = 0 Then  {Chain 4 (Bit 3) inactive ?}
  33.     Mode:=$ff;                  {then Mode X}
  34.  
  35.   Port[$3d4]:=$0d;              {Linear Starting Address Low (CRTC 0dh)}
  36.   LSA:=Port[$3d5];              {read out}
  37.   Port[$3d4]:=$0c;              {Linear Starting Address High (CRTC 0ch)}
  38.   LSA:=LSA or Port[$3d5] shl 8; {read out and enter}
  39.  
  40.   Port[$3d4]:=$18;              {Line Compare CRTC 18h}
  41.   Split_at:=Port[$3d5];         {read out}
  42.   Port[$3d4]:=7;                {Overflow Low}
  43.   Split_at:=Split_at or         {mask out Bit 4 and move to Bit 8}
  44.     (Port[$3d5] and 16) shl 4;
  45.   Port[$3d4]:=9;                {Maximum Row Address}
  46.   Split_at:=Split_at or         {mask out Bit 6 and move to Bit 9}
  47.     (Port[$3d5] and 64) shl 3;
  48.   Split_at:=Split_at shr 1;     {convert to screen lines}
  49.  
  50.   Port[$3d4]:=$13;              {Row Offset (CRTC Register 13h)}
  51.   Skip:=Port[$3d5];             {read out}
  52.   Skip:=Skip*2-80               {read difference to "normal" line spacing}
  53. End;
  54.  
  55.  
  56. Procedure PCXShift;assembler;
  57. {prepares current palette for PCX (shift 2 to the left)}
  58. asm
  59.   mov si,offset palette         {pointer to palette in ds:si}
  60.   mov cx,768                    {process 768 bytes}
  61. @lp:
  62.   lodsb                         {get value}
  63.   shl al,2                      {shift}
  64.   mov ds:[si-1],al              {write back to old position}
  65.   loop @lp                      {and complete loop}
  66. End;
  67.  
  68. Var pcx:File;                   {PCX file to disk}
  69.  
  70. Procedure Hardcopy(Startaddr,splt:Word;s : string);
  71. {copies graphic 320x200 (Mode 13 o. X) as PCX to file s}
  72. {current screen start (Linear Starting Address) in Startaddr}
  73. {Split line in splt}
  74. Var Buf:Array[0..57] of Byte;   {receives data before saving}
  75.     Aux_Ofs:Word;
  76. const
  77.   Header1:Array[0..15] of Byte  {PCX header, first part}
  78.     =($0a,5,1,8, 0,0, 0,0, $3f,1, 199,0,$40,1,200,0);
  79.   Header2:Array[0..5] of Byte   {PCX header, first part}
  80.     =(0,1,$40,1,0,0);
  81.   plane:Byte=0;                 {current plane no.}
  82.  
  83. var count:Byte;                 {number of equivalent characters}
  84.     value,                      {value just fetched}
  85.     lastbyt:Byte;               {previous value}
  86.     i:word;                     {byte counter}
  87.  
  88. begin
  89. asm                             {read out palette}
  90.   xor al,al                     {start with color 0}
  91.   mov dx,3c7h                   {use Pixel Read Address }
  92.   out dx,al                     {to inform DAC of this}
  93.  
  94.   push ds                       {pointer es:di to palette}
  95.   pop es
  96.   mov di,offset palette
  97.   mov cx,768                    {read out 768 bytes}
  98.   mov dx,3c9h                   {Pixel Color Value}
  99.   rep insb                      {and read}
  100.  
  101.   cmp mode,13h                  {Mode X ?}
  102.   je @Linear                    {then:}
  103.   mov dx,03ceh                  {set write and read mode to 0}
  104.   mov ax,4005h                  {using GDC-Register 5 (GDC Mode)}
  105.   out dx,ax
  106. @Linear:
  107. End;
  108.  
  109.   Assign(pcx,s);                {open file for writing}
  110.   Rewrite(pcx,1);
  111.  
  112.   BlockWrite(pcx,Header1,16);   {write Header part 1}
  113.   PCXShift;                     {prepare palette}
  114.   BlockWrite(pcx,palette,48);   {enter first 16 colors}
  115.   BlockWrite(pcx,Header2,6);    {write Header part 1}
  116.   FillChar(buf,58,0);           {write 58 nulls (fill header)}
  117.   BlockWrite(pcx,buf,58);
  118.   plane:=0;                     {start with Plane 0}
  119.   count:=1;                     {initialize number with 1}
  120.   If splt<200 Then
  121.     If Mode = $ff Then
  122.       splt:=splt*80 Else        {calculate Split-Offset}
  123.       splt:=splt*320 Else       {varies depending on mode}
  124.     Splt:=$ffff;
  125.   If Mode=$13 Then              {LSA refers to the plane model !}
  126.     Startaddr:=Startaddr*4;
  127.   for i:=0 to 64000 do Begin    {process each pixel}
  128.   If i shr 2 < splt Then
  129.   aux_ofs:=(i div 320) * skip   {set auxiliary offset taking }
  130.                                 {line width into consideration}
  131.   Else
  132.   aux_ofs:=((i shr 2 - splt) div 320) * skip;
  133.                                 {with splitting reference to VGA-Start}
  134. asm                             {read out pixel}
  135.   mov ax,0a000h                 {load segment}
  136.   mov es,ax
  137.   mov si,i                      {load offset}
  138.   cmp mode,13h                  {Mode 13h ?}
  139.   je @Linear1
  140.   shr si,2                      {no, then calculate offset}
  141. @Linear1:
  142.   cmp si,splt                   {Split-Line reached ?}
  143.   jb @continue                  {no, then continue}
  144.   sub si,splt                   {otherwise, apply everything else}
  145.   sub si,startaddr              {to screen start}
  146. @continue:
  147.   add si,startaddr              {add start address}
  148.   add si,aux_ofs                {add auxiliary offset}
  149.  
  150.   cmp mode,13h                  {Mode 13h ?}
  151.   je @Linear2                   {no, then Mode X read method}
  152.   mov dx,03ceh                  {using GDC-Register 4 (Read Plane Select)}
  153.   mov ah,plane                  {select current plane}
  154.   inc plane                     {and continue shifting}
  155.   mov al,4
  156.   and ah,03h
  157.   out dx,ax
  158. @Linear2:
  159.   mov al,es:[si]                {read out byte}
  160.   mov value,al                  {and save in value variable}
  161. End;
  162.   If i<>0 Then Begin            {no compression with first byte}
  163.   If (Value = lastbyt) Then Begin{same bytes ?}
  164.     Inc(Count);                 {then increment counter}
  165.     If (Count=64) or            {counter too high already ?}
  166.      (i mod 320 =0)  Then Begin {or beginning of line ?}
  167.       buf[0]:=$c0 or (count-1); {then buffer}
  168.       buf[1]:=lastbyt;          {write counter status and value}
  169.       count:=1;                 {reinitialize counter}
  170.       BlockWrite(pcx,buf,2);    {and to disk}
  171.     End;
  172.   End Else                      {different bytes :}
  173.     If (Count > 1) or           {several of the same ?}
  174.     (lastbyt and $c0 <> 0) Then {value too large for direct writing ?}
  175.     Begin
  176.       buf[0]:=$c0 or count;     {then write number and value to file}
  177.       buf[1]:=lastbyt;
  178.       lastbyt:=Value;           {current value for further compression}
  179.       Count:=1;                 {save and reinitialize}
  180.       BlockWrite(pcx,buf,2);
  181.     End Else Begin              {single, legal byte:}
  182.       buf[0]:=lastbyt;          {direct writing}
  183.       lastbyt:=Value;           {save current value for later}
  184.       BlockWrite(pcx,buf,1);
  185.     End;
  186.  
  187.   End Else lastbyt:=value;      {with first byte save only}
  188. End;
  189.   buf[0]:=$0c;                  {insert ID palette}
  190.   blockwrite(pcx,buf[0],1);     {and write}
  191.   blockwrite(pcx,palette,256*3);{and add palette}
  192.   Close(pcx);                   {close file}
  193. End;
  194.  
  195.  
  196. Procedure Action;
  197. {called upon activation of the hot-key}
  198. Var nrs:String;                 {string for assigning name}
  199. Begin
  200.   if not active Then Begin      {only if not already active}
  201.     active:=true;               {note as active}
  202.     str(no,nrs);                {convert number to string and increment}
  203.     Inc(no);
  204.     GetMode;                    {get graphic mode etc.}
  205.     If Mode <> 0 Then
  206.       HardCopy(LSA,Split_at,'hard'+nrs+'.pcx');
  207.                                 {run hard copy}
  208.     active:=false;              {release renewed activation}
  209.   End;
  210. End;
  211.  
  212. Procedure Handler9;interrupt;assembler;
  213. {new interrupt handler for keyboard IRQ}
  214. asm
  215.    pushf
  216.    call [oldint9]               {call old IRQ 1 - handler}
  217.  
  218.   cli                           {no further interrupts}
  219.   in al,60h                     {read scan code}
  220.   cmp al,34d                    {G ?}
  221.   jne @finished                 {no -> end handler}
  222.   xor ax,ax                     {load 0 segment}
  223.   mov es,ax
  224.   mov al,es:[417h]              {read keyboard status}
  225.   test al,8                     {Bit 8 (Alt key) set ?}
  226.   je @finished                  {no -> end handler}
  227.  
  228.   call action                   {run hard copy}
  229. @finished:
  230.   sti                           {allow interrupts again}
  231. End;
  232.  
  233. Procedure identification;assembler;
  234. {Dummy-Procedure, contains Copyright message for installation ID}
  235. {NOT EXECUTABLE CODE !}
  236. asm
  237.   db 'Screen-Grabber, (c) Data Becker 1995/Abacus 1995';
  238. End;
  239.  
  240. Procedure Check_Inst;assembler;
  241. {Checks whether Grabber is already installed}
  242. asm
  243.   mov installed,1               {Assumption: already installed}
  244.   push ds                       {ds still needed !}
  245.   les di,oldint9                {load pointer to old handler}
  246.   mov di,offset identification  {Procedure identification in same segment}
  247.   mov ax,cs                     {set ds:si to identification of this program}
  248.   mov ds,ax
  249.   mov si,offset identification
  250.   mov cx,20                     {compare 20 characters}
  251.   repe cmpsb
  252.   pop ds                        {restore ds}
  253.   jcxz @installed               {equal, then already installed}
  254.   mov installed,0               {not installed: note}
  255. @installed:
  256. End;
  257.  
  258. Begin
  259.   no:=0;                        {first filename: hard0.pcx}
  260.   GetIntVec(9,OldInt9);         {get old interrupt vector}
  261.   Check_Inst;                   {check whether already installed}
  262.   If not installed Then Begin   {if no:}
  263.     SetIntVec(9,@Handler9);     {install new handler}
  264.     WriteLn('Grabber installed');
  265.     WriteLn('(c) Data Becker 1995/Abacus 1995');
  266.     WriteLn('Activation with <alt> g');
  267.     Keep(0);                    {output message and exit resident}
  268.   End;
  269.   WriteLn('Grabber already installed');
  270.                                 {if already installed, message and exit}
  271. End.
  272.