Announcement

Collapse
No announcement yet.

PB/DOS - copy a single file with various options

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PB/DOS - copy a single file with various options

    Code:
    '-------------------------------------------------------------------------------
    '
    '      Unit: dosenv.pbl
    '     Zweck: Lesen und Ändern der Umgebung des zuletzt geladenen COMMAND.COM,
    '            verbesserte Version (optimierte, kompatible Nachfolgeversion
    '            von environ4 mit einigen Erweiterungen und Bugfixes).
    '   Version: 1.00
    '     Stand: 20.03.2000
    '   Sprache: PowerBASIC 3.5
    '     Autor: (C) M.Hoffmann, Wedeler Landstr.139, 22559 Hamburg.
    '  Historie:
    '
    '-------------------------------------------------------------------------------
    ' c: environ4.pbu      5534   5.04.98  14:42   (Vorgänger)
    ' c: dosenv  .pbu      5660  20.03.00  15:32   v1.00
    '-------------------------------------------------------------------------------
    ' Die hier beschriebene Methode zur Bestimmung der Umgebungsadresse
    ' lief bislang überall zuverlässig (auch unter Win 9x). Zwei weitere
    ' Methoden, um die Umgebung des ZUERST geladenen Kommandoprozessores zu bestim-
    ' men (MCB-Kette, Einstieg über Funktion 52h; INT 2Eh als Pointer auf COMMAND)
    ' funktionieren entweder nicht in der OS/2 1.3 DOS-Box oder nicht mit anderen
    ' Kommandoprozessoren (INT 2Eh zeigt nicht auf den NDOS-Prozessor).
    ' die maximale Größe einer Umgebung etwas weniger als 32k (32750), ACHTUNG:
    ' die Einstellung $STRING im Hauptprogramm ist entsprechend zu setzen!
    ' Lesefunktionen beziehen sich auf die möglicherweise bereits veränderte Kopie
    ' der Umgebung, nicht mehr auf die Originaltabelle!
    '-------------------------------------------------------------------------------
    ' Anmerkungen zur Verwendung eines Pointers zur direkten Änderung der Umgebung:
    ' Durch Definition von @envBuf als String Ptr*32750 würde beim Löschen
    ' oder Einfügen von Variablen der Bereich hinter dem tatsächlichen Ende der
    ' Umgebungsvariablen hin- und hergeschoben, also korrumpiert !!! Ein korrektes
    ' Definieren via 'dim envBuf as string ptr*<envLen>' ist aber nicht möglich,
    ' weil für die Stringlänge eine Konstante angegeben werden muss!!
    '-------------------------------------------------------------------------------
    '
    ' ┌───────────────────┬────&#947 2;─────────────────────────&#9 472;─────────────────────────& #9488;
    ' │ envBlock()        │ Komletten Umgebungsblock zurückgeben                   │
    ' │ envClear()        │ Löscht eine Variable aus dem Umgebungsblock            │
    ' │ envCount()        │ Liefert Anzahl der Variablen im Umgebungsblock zurück  │
    ' │ envEntries()  NEU │ Liefert ALLE Einträge zurück                           │
    ' │ envEntry()        │ Liefert gesamten Eintrag anhand des Varnamens zurück   │
    ' │ envEnum()         │ Liefert Eintrag Nr. n aus der Umgebungstabelle zurück  │
    ' │ envFree()         │ Größe des noch freien Umgebungsspeichers zurückgeben   │
    ' │ envInfo           │ Adresse und Länge des letzten Umgebunsblocks bestimmen │
    ' │ envLen()          │ Länge des Umgebungsblocks zurückgeben                  │
    ' │ envLoad()         │ Initialisieren der Umgebungsfunktionen                 │
    ' │ envName()     NEU │ Formatiert den Variablennamen gemäß envStyle()         │
    ' │ envSave()         │ Schreibt den Umgebungsblock in den Speicher zurück     │
    ' │ envSet()          │ Fügt einen neuen Eintrag in den Umgebungsblock ein     │
    ' │ envStyle()    ERW │ Bestimmt oder setzt Bearbeitungsmodus DOS oder INTERN  │
    ' │ envUsed()         │ Größe des belegten Umgebungsspeichers zurückgeben      │
    ' │ envValue()        │ Liefert Inhalt anhand eines Variablennamens zurück     │
    ' └───────────────────┴────&#947 2;─────────────────────────&#9 472;─────────────────────────& #9496;
    
    '---Compiler--------------------------------------------------------------------
    
    $compile  unit
    $cpu      80386
    $debug    map-,pbdebug-,path-,unit-
    $dim      all
    $error    all-
    $event    off
    $float    emulate
    $lib      all-
    $optimize size
    $static
    $option   gosub-,signed-
    $string   32 ' -> im Hauptprogramm erforderlich!
    
    defint a-z
    
    '===============================================================================
    ' SHARED-Vars in dieser Unit
    '
    dim envPtr as shared string ptr*32750 ' Zeiger erspart def seg/peek/poke
    dim envBuf as shared flex             ' Kopie der Umgebungstabelle
    dim envLn  as shared word             ' Länge des GESAMTEN Blocks
    dim eLeft  as shared integer          ' Anzahl Bytes VOR einer bestimmten Var
    dim eRight as shared integer          ' Byteposition NACH einer bestimmten Var
    dim eStyle as shared integer          ' Bestimmt Formatierung des Varnamens
    
    '===============================================================================
    ' Bestimmung der Umgebung DES ZULETZT GELADENEN COMMAND.COM (Adresse, Länge).
    ' COMMAND.COM ist dann gefunden, wenn die Adresse des 'Calling_PSP' gleich der
    ' eigenen, aktuellen PSP-Adresse ist.
    ' Es gibt keine Fehlerprüfung - wenn auf diese Weise COMMAND.COM nicht gefunden
    ' wird, läuft die Routine unweigerlich ins Nirwana. Eine effiziente Abfrage
    ' Dieser beiden Parameter ist nur zusammen möglich, daher keine Funktionen.
    ' Normalerweise wird die Routine nur intern verwendet, sie ist aber dennoch
    ' PUBLIC definiert.
    ' => Aus Gründen der Kompatibilität weiterhin nur Segmentadresse liefern!
    '
    sub envInfo (eSeg as word,eLen as word) local public
       ! mov ax,&h6200    ;
       ! int &h21         ;
       ! jc  envInfoX     ; bei INT-Fehler sofort abbrechen (neu in v5)
      envInfo1:           '
       ! mov es,bx        ; BX enthält nach INT21,62 Adresse des aktiven PSP
       ! mov bx,es:[&h16] ; Dort steht an Offset 16h Adresse des AufruferPSP
       ! mov ax,es        ; In BX steht jetzt Aufrufer-PSP, in AX vorheriges
       ! cmp bx,ax        ; Sind diese beiden gleich, ist COMMAND gefunden!
       ! jne envInfo1     ; (Achtung: Endlosschleife möglich)
       ! mov ax,es:[&h2c] ; Offset &h2c enthält Adresse des Umgebungsblocks
       ! les bx,eSeg      ;
       ! mov es:[bx],ax   ; Adresse in eSeg zurückliefern
       ! dec ax           ;
       ! mov es,ax        ;
       ! mov ax,es:[3]    ; Im MCB davor steht Größe des Bereichs in Paragraphen
       ! mov cl,4         ;
       ! shl ax,cl        ; * 16 = Bytes
       ! les bx,eLen      ;
       ! mov es:[bx],ax   ; Bytes in eLen zurückliefern
      envInfoX:           '
    end sub
    
    '===============================================================================
    ' Laden des Umgebungsblocks zur weiteren Bearbeitung durch die Unit,
    ' -1 = Fehler, 0 = Ok (Vorgabe).
    '
    function envLoad() local public as integer
       dim envSeg as local word
       envInfo envSeg, envLn
       ' spart 5 Byte ggü. MIN (MIN% wegen Overflow nicht anwendbar)
       incr envLn
       if envLn > fre(-4) or envLn > fre(-1) or envLn = 0 then
          function = -1
          exit function
       end if
       ! mov ax,envSeg
       ! mov envPtr[2],ax
       map envBuf*envLn
       decr envLn
       envBuf=chr$(0)+left$(@envPtr,envLn)
    end function
    
    '===============================================================================
    ' Automatische Ausführung von envLoad() bei Bedarf (neu in v5)
    function envCheck () local private as integer
       if len(envBuf) = 0 then      ' Pointer noch nicht gesetzt
          function = envLoad() ' -> Pointer setzen, ggf. Fehler zurück
       end if
       ' Vereinfacht in allen Routinen folgende Konstrukte:
       '  if envBuf = 0 then
       '     if envLoad() then
       '        exit function
       '     end if
       '  end if
       ' zu:
       '  if envCheck() then
       '     exit function
       '  end if
    end function
    
    '===============================================================================
    ' Liefert den gesamten aktuellen Umgebungsblock zurück, "" (vermutlich) Fehler
    '
    function EnvBlock() local public as string
       if envCheck() then
          exit function
       end if
       function = mid$(envBuf,2)
    end function
    
    '===============================================================================
    ' Kapselungsfunktion: liefert Länge der Umgebungstabelle zurück (-1=Fehler).
    '
    function EnvLen() local public as integer
       if envCheck() then
          function = -1
          exit function
       end if
       function = envLn
    end function
    
    '===============================================================================
    ' Bestimmt, wieviel Platz in der Umgebungstabelle belegt ist, -1 = Fehler.
    ' ACHTUNG: Abschließende (2.) NULL zählt mit!
    '
    function EnvUsed() local public as integer
       if envCheck() then
          function = -1
          exit function
       end if
       function = instr(envBuf,chr$(0,0)) ' wg. NULL zu Beginn entfällt +1
    end function
    
    '===============================================================================
    ' Bestimmt, wieviel Platz in der Umgebungstabelle frei ist. Fehler: <= 0
    ' (macht Sinn, damit ein Programm dann nicht dort herumfuhrwerkt).
    '
    function EnvFree() local public as integer
       ' Hinweis: Funktion envLen() statt globaler Var envLn benutzen, damit
       ' ggf. envLoad() zunächst ausgeführt wird!
       function = envLen()-envUsed()
    end function
    
    '===============================================================================
    ' Steuert Formatierung des Variablennamens (Auswertung in envName()).
    ' Setzt einen neuen Style (newStyle => 0) oder fragt den aktuellen Style
    ' lediglich ab (newStyle = -1). Bei Veränderungen wird VORHERIGER Style zurück-
    ' gegeben. Style kann folgende Werte annehmen:
    '  0 (Vorgabe): führende und nachfolgende Leerstellen entfernen & UCASE
    '  1 (MSDOS)  : nur führende Leerstellen entfernen & UCASE
    '  * (Win 9x) : keine Änderung (siehe 'windir' und 'winbootdir')
    '
    function envStyle (byval newStyle as integer) local public as integer
       function = eStyle
       if newStyle => 0 then
          eStyle = newStyle
       end if
    end function
    
    '===============================================================================
    ' Formatiert den übergebenen Variablennamen gemäß Einstellung envStyle().
    '
    function envName (inName as string) local public as string
       select case eStyle
          case 0   : function = ucase$( trim$(inName))
          case 1   : function = ucase$(ltrim$(inName))
          case else: function = inName
       end select
    end function
    
    '===============================================================================
    ' Liefert Inhalt einer Umgebungsvariablen zurück, "" = Var nicht vorhanden
    ' oder Fehler (hier nicht unterscheidbar). ACHTUNG: Variablennamen werden
    ' immer in GROSSBUCHSTABEN erwartet!
    ' => envClear() ruft envValue und greift dann auf eLeft und eRight zurück!
    '
    function envValue (VarName as string) local public as string
       dim tmp as local integer
       if envCheck() then
          exit function
       end if
       eLeft = instr(envBuf,chr$(0)+envName(VarName)+"=")
       if eLeft then
          tmp      = eLeft+Len(VarName)+2
          eRight   = instr(tmp,envBuf,chr$(0)) ' +1 (Fehler environ4?) ?
          function = mid$(envBuf,tmp,eRight-tmp)
          incr eRight
       end if
    end function
    
    '===============================================================================
    ' Liefert einen bestimmte Umgebungseintrag zurück, "" = Var nicht vorhanden
    ' oder Fehler (hier nicht unterscheidbar). ACHTUNG: Variablennamen werden
    ' immer in GROSSBUCHSTABEN erwartet!
    '
    function envEntry (VarName as string) local public as string
       dim tmp as local integer
       if envCheck() then
          exit function
       end if
       tmp = instr(envBuf,chr$(0)+envName(VarName)+"=")
       if tmp then
          function = extract$(mid$(envBuf,tmp+1),chr$(0))
       end if
    end function
    
    '===============================================================================
    ' Liefert ALLE  Umgebungseinträge zurück, jeder Eintrag wird durch NULL
    ' abgeschlossen (ohne abschließende zweite NULL) "" -> (vermutlich) Fehler
    '
    function envEntries () local public as string
       if envCheck() then
          exit function
       end if
       function = mid$(extract$(envBuf,chr$(0,0))+chr$(0),2)
    end function
    
    '===============================================================================
    ' Löscht eine Variable aus der Umgebung. -1 = Fehler, -2 = Var nicht vorhanden.
    ' ACHTUNG: Variablennamen werden immer in GROSSBUCHSTABEN erwartet!
    ' => greift auf eLeft und eRight aus envValue() zurück!
    '
    function EnvClear (VarName as string) local public as integer
       if envCheck() then
          function = -1
          exit function
       end if
       if len(envValue(VarName)) then ' dadurch wurden eLeft, eRight gesetzt!
          envBuf = left$(envBuf,eLeft)+mid$(envBuf,eRight)
       else
          function = -2
       end if
    end function
    
    '===============================================================================
    ' Liefert die Anzahl von Einträgen in der Umgebungstabelle, -1 = Fehler.
    '
    function EnvCount() local public as integer
       if envCheck() then
          function = -1
          exit function
       end if
       function = tally(extract$(envBuf,chr$(0,0)),chr$(0))
       ' stimmt so wegen zusätzlicher NULL am Anfang!
    end function
    
    '===============================================================================
    ' Liefert den xten Umgebungseintrag als 'name=var', "" -> keine weiteren Vars
    ' oder Fehler (hier nicht unterscheidbar). idx beginnt bei 1.
    '
    function EnvEnum (byval idx as integer) local public as string
       dim i as local integer
       dim j as local integer
       if envCheck() then
          exit function
       end if
       for j=1 to idx
          i = instr(i+1,envBuf,chr$(0))
          incr i
          if ascii(envBuf,i) = 0 then
             exit function
          end if
       next
       function = extract$(mid$(envBuf,i),chr$(0))
    end function
    
    '===============================================================================
    ' Fügt einen neuen Eintrag in die Umgebungstabelle ein, -1 = Fehler, -3 = zu
    ' wenig freier Platz, -2 = ungültige Zeichen in VarName/-Value oder Name leer.
    ' ACHTUNG: Neue Variablen werden immer AM ENDE der Tabelle eingefügt.
    '
    function envSet (byval VarName as string, VarValue as string) local public as integer
       dim newEntry as local string
       dim oldLen   as local integer
       if envCheck() then
          function = -1
          exit function
       end if
       if instr(VarName+VarValue,any chr$(0,61))>0 or len(VarName)=0 then
          ' ungültige Zeichen abweisen (ACHTUNG: was prüft DOS?
          '=' ist hier auch in VarValue verboten!
          function = -2
          exit function
       end if
       newEntry = envName(VarName)+"="+VarValue
       OldLen = len(envEntry(VarName)) ' falls schon vorhanden
       if envFree()+OldLen-len(newEntry) < 0 then
          function = -3
          exit function
       end if
       if OldLen then
          envClear VarName
       end if
       mid$(envBuf,envUsed()+1) = newEntry+chr$(0,0)
    end function
    
    '===============================================================================
    ' Schreibt den angegebenen oder gepufferten String in den Umgebungsblock,
    ' -2 = Ungültiger Umgebungsblock*. Mit EnvSave(chr$(0,0)) kann der
    ' komplette Umgebungsblock gelöscht werden!
    ' *Folgendes wird NICHT geprüft: Variablennamen in Großbuchstaben, führende
    ' Leerzeichen vor VarNamen. Schreibt das Programm auf eigene Regie einen
    ' Umgebungsblock, muß dieser VORHER entsprechend geprüft werden!
    ' Neu: wenn kein Block geladen wurde, wird nichts geschrieben und auch
    ' kein Fehler zurückgeliefert (logisch richtig).
    '
    function EnvSave (newEnv as string) local public as integer
       if len(newEnv) then
          if len(newEnv) <= EnvLen() and instr(newEnv,chr$(0,0)) > 0 then
             envBuf = chr$(0)+ltrim$(newEnv,chr$(0))
          else
             function = -2
          end if
       end if
       ' nur belegten Bereich zurückschreiben (egal, ob verändert)
       if len(envBuf) then
          mid$(@envPtr,1) = mid$(envBuf,2,envUsed())
       end if
    end function
    
    '****Ende der Unit**************************************************************
    ------------------
Working...
X