Code:
'-------------------------------------------------------------------------------
'      Unit: redir4.pbl
'     Zweck: Funktionen für Geräte-Umleitung (Netzwerk) und zum Auslesen
'            von Infos zu umgeleiteten Geräten, Implementation von TRUENAME.
'   Version: 1.03
'     Stand: 15.01.1999
'   Sprache: PowerBASIC 3.5
'     Autor: (C) M.Hoffmann, Wedeler Landstr.139, 22559 Hamburg.
'  Benötigt:
'  Historie:
'      1.00: Erste Version aus Unit redir3 weiterentwickelt:
'            Implementation der ursprünglich in MS-DOS enthaltenen, undokumen-
'            tierten TRUENAME Funktion (INT 21h, Subfunktion 60h), die in einer
'            WfW-Dosbox nur teilweise und unter Win95 so gar nicht funktioniert.
'            Alle Programme und Libraries, die TRUENAME-Funktionen verwenden,
'            müssen diese Funktionen verwenden, um fehlerfrei unter WfW bzw.
'            Win95 zu laufen. Dokumentation zu TRUENAME siehe DOS7FS1-Unit.
'      1.01: Bugfixing für RedirTruename (PFAD-Komponente fehlte); nur
'            KURZE DATEINAMEN zurückliefern (CL=01).
'      1.02: Anpassungen für PB 3.5; ASM; Bugfixes; Optimierungen; IsDriveRemote
'            und Truename-Codierung von DOS7FS1 übernommen (modifiziert);
'            ACHTUNG: RedirGetItem(Parm1) jetzt BYVAL übergeben!
'            Bei RedirAdd(LM) wird das Passwort unter LM/WfW/W95 ignoriert,
'            man muß bereits angemeldet sein (29.6.98).
'      1.03: Bei allen Fehlern aus 21/7160 danach 21/60 probieren (FullFile-
'            name). Grund: Bei Angabe nicht existierender Dateien liefert
'            21/7160 einen Fehlercode zurück.
'  Hinweise: Außer bei RedirAddLM werden die Netzwerkaufrufe des DOS-Kernels
'            (5F0x) benutzt, anstelle der undokumentierten LAN Manager-Calls
'            (5F3x/4x/5x). Weitere Calls in DOS7FS1.
'-------------------------------------------------------------------------------
' c: redir4  .pbu      5720  23.09.97  13:18   1.00
' c: redir4  .pbu      5740  24.09.97   9:59   1.01
' c: redir4  .pbu      4274  29.06.98  13:31   1.02
' c: redir4  .pbu      4258  15.01.99  11:37   1.03

'---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-

defint a-z

'---Deklarationen---------------------------------------------------------------

%lenlocal   = 16
%lenremote  = 128
%lenbuf     = 261

' LAN-Manager use_info_1-Struktur

type UseInfo1Type
   Locl    as asciiz*9
   Padding as string*1
   pRmot   as dword
   pPswd   as dword
   lnksta  as word ' Linkstate (nicht benutzt)=
   UseTyp  as word ' -1 wildcard 0 disk 1 print 2 com 3 ipc
   ignor1  as word
   ignor2  as word
end type

'---Routinen--------------------------------------------------------------------

function RedirIsDriveRemote (drive as string) local public as integer
   dim drv as local byte
   if len(drive) then
      drv = ascii(ucase$(drive))-64 ' keine Gültigkeitsprüfung
   end if
   ! pushf                      ;
   ! mov   ax, &h4409           ;
   ! mov   bl, drv              ;
   ! int   &h21                 ;
   ! jc    RedirIsDriveRemoteEX ;
   ! mov   ax, dx               ;
   ! mov   cl, 12               ;
   ! shr   ax, cl               ;
   ! and   ax, 1                ;
   ! neg   ax                   ;
redirIsDriveRemoteEX:           '
   ! neg   ax                   ;
   ! mov   function,ax          ;
   ! popf                       ;
end function

'-------------------------------------------------------------------------------

function RedirGetItem (byval Index  as integer,_ ' E: Index von 0...n
                             Lokal  as string ,_ ' A: Lokaler Ressourcename
                             Remote as string ,_ ' A: UNC-Name \\server\share
                             DevTyp as integer,_ ' A: Einheitentyp 3=Prt 4=Disk 0=?
                             Connct as integer _ ' A: ConnState 0=Ok 1=Disc >2=Err
                      ) public as integer  ' : 0=Ok 18=Eof n=Err -1=invEntry

   ' Holt Eintrag #Index aus der Redirektionsliste in die Variablen.
   ' Ergebnis: 0 = Ok, Eintrag gelesen
   '          -1 = ungültiger Eintrag? (BH <> 0,1,2)
   '           n = Betriebssystemfehlercode aus AX (18 = Ende der Liste)
   ' Wegen Aufwärtskompatibilität bleibt die merkwürde Rückgabekonvention.

   dim lkl as local asciiz*%lenlocal
   dim rmt as local asciiz*%lenremote
   DevTyp = 0 ' Vorbesetzung; 3=Drucker,4=Disk,0=undefined/Error

   ! pushf                  ;
   ! push  ds               ;
   ! push  si               ;
   ! push  di               ;
   ! mov   ax, ss           ;
   ! lea   bx, lkl          ; Adresse von 'lkl' über SS:BX
   ! mov   si, bx           ;
   ! mov   ds, ax           ; in DS:SI laden
   ! lea   bx, rmt          ; Adresse von 'rmt' über SS:BX
   ! mov   di, bx           ;
   ! mov   es, ax           ; in ES [img]http://www.powerbasic.com/support/forums/biggrin.gif[/img]I laden
   ! mov   ax, &h5f02       ;
   ! mov   bx, Index        ;
   ! push  bp               ; wird laut INTLIST-Doku zerstört?
   ! int   &h21             ;
   ! pop   bp               ;
   ! jc    RedirGetItemEX   ;
   ! mov   ax, -1           ;
   ! cmp   bh, 2            ;
   ! jg    RedirGetItemEX   ;
   ! xor   ax, ax           ;
   ! les   si, DevTyp       ;
   ! mov   es:[si], bl      ;
   ! les   si, Connct       ;
   ! mov   es:[si], bh      ;
RedirGetItemEX:             '
   ! pop   di               ;
   ! pop   si               ;
   ! pop   ds               ;
   ! popf                   ;
   ! mov   function, ax     ;
   Lokal  = lkl
   Remote = rmt

end function

'-------------------------------------------------------------------------------

function RedirGetInfo (Resrc  as string ,_ ' E: Lokaler/Entfernter Rsrc-Name
                       State  as integer _ ' A: Verbindungs-Status
                      ) public as string   '  : Entfernter/lokaler Rsrc-Name

   ' Durchsucht mittels RedirGetItem die Redirektionsliste, bis ein zum
   ' lokalen/entfernten Ressource-Namen passender Eintrag gefunden wird, und
   ' gibt den passenden Remote/Lokal-Namen zurück, sowie den Linkstatus.
   ' Der EinheitenTYP interessiert hier nicht, da der Einheitenname ja als
   ' Eingabeparameter dient, der Typ mithin also bekannt sein dürfte.
   ' Der Eingabeparameter wird nicht überprüft, lediglich vor dem Vergleich
   ' in Großbuchstaben umgewandelt. Liefert Leerstring, wenn kein passender
   ' Eintrag gefunden wird. Ab v1.10 ist Funktion auch zu Ermittlung des
   ' lokalen Namens passend zum angegebenen entfernten Namen verwendbar.

   dim i    as local integer
   dim locl as local string
   dim rmte as local string
   dim temp as local string
   dim func as local integer
   temp = ucase$(extract$(Resrc,":"))
   if len(temp) = 1 then
      if RedirIsDriveRemote(temp) = 0 then
         exit function
      end if
      temp = temp+":"
   end if
   do
      func = redirGetItem(i,locl,rmte,0,State)
      if func = 0 then ' gültiger Redirektionseintrag
         if left$(temp,2) = "\\" then
            swap locl,rmte
         end if
         if temp = locl then
            function = rmte
            exit function
         end if
      elseif func = 18 then ' End_of_List
         exit function
      elseif func <> -1 then
         exit function
      end if ' nur bei -1 (=ungültiges Element): weitersuchen
      incr i
   loop
end function

'-------------------------------------------------------------------------------

function RedirGetList (Lokal(1)  as string, _ ' A: Lokale Ressourcenamen
                       Remote(1) as string, _ ' A: UNC-Namen \\server\share
                       DevTyp(1) as integer,_ ' A: Devicetypen 3=Prt 4=Disk 0=?
                       Connct(1) as integer _ ' A: ConnStates 0=Ok 1=Disc >2=Err
                      ) public as integer     '  : Anzahl Array-Elemente

   ' Dies ist eine Art High-Level-Aufruf der Enumeratefunktion RedirGetItem,
   ' um dem Hauptprogramm das Hantieren mit eigenen Schleifen zu ersparen.
   ' Wenn Rückgabewert < 0, ist Fehler aufgetreten, sonst Anzahl Elemente.
   ' Es können nicht mehr Infos geliefert werden, als in die Arrays passen
   ' (der größte gemeinsame untere Index und der kleinste gemeinsame obere
   ' Arrayindex begrenzen die Anzahl der zurückgebbarer Elemente).

   dim i     as local integer
   dim LstIx as local integer
   dim HIndx as local integer
   dim LIndx as local integer
   dim Rc    as local integer

   HIndx = min%(ubound(Lokal(1)) ,_
                ubound(Remote(1)),_
                ubound(DevTyp(1)),_
                ubound(Connct(1)))
   LIndx = max%(lbound(Lokal(1)) ,_
                lbound(Remote(1)),_
                lbound(DevTyp(1)),_
                lbound(Connct(1)))

   for i=LIndx to HIndx
      rc = RedirGetItem(LstIx,Lokal(i),Remote(i),DevTyp(i),Connct(i))
      incr LstIx
      if rc then
         if rc = 18 then
            exit for
         elseif rc <> -1 then
            function = -rc
            exit function
         end if
      end if
   next
   function = LstIx-1

end function

'-------------------------------------------------------------------------------

function RedirAdd (Lokal  as string,_ ' E: Lokaler Ressourcename
                   Remote as string,_ ' E: Entfernter Res.name (\\server\share)
                   PassWd as string _ ' E: Passwort wahlweise
                  ) public as integer '  : 0=Ok, n=Betriebssystemcode

   ' Fügt einen Eintrag in die Redirektionstabelle ein (NET USE...)

   dim Lkl as local asciiz*%lenlocal
   dim Rmt as local asciiz*%lenremote
   dim ll  as local integer

   Lkl = Lokal
   ll  = len(Lkl)
   Rmt = Remote+chr$(0)+ucase$(PassWd)

   ! pushf                  ;
   ! push  ds               ;
   ! push  si               ;
   ! push  di               ;
   ! push  bp               ; eines dieser Register wird
   ! push  ss               ; von WIN95 zerstört (DOS ok)
   ! mov   ax, ss           ;
   ! lea   bx, lkl          ; Adresse von 'lkl' über SS:BX
   ! mov   si, bx           ;
   ! mov   ds, ax           ; in DS:SI laden
   ! lea   bx, rmt          ; Adresse von 'rmt' über SS:BX
   ! mov   di, bx           ;
   ! mov   es, ax           ; in ES [img]http://www.powerbasic.com/support/forums/biggrin.gif[/img]I laden
   ! mov   bl, 4            ; Defaultresourcetyp = 4 = Disk
   ! cmp   ll, 3            ; ShareTYP automatisch anhand von Länge(Lokal) prüfen
   ! jb    RedirAdd1        ; ok
   ! mov   bl, 3            ; Resourcetyp = 3 = Print
RedirAdd1:                  '
   ! mov   ax, &h5f03       ;
   ! xor   cx, cx           ;
   ! int   &h21             ;
   ! jc    RedirAddEX       ;
   ! xor   ax, ax           ;
RedirAddEX:                 '
   ! pop   ss               ;
   ! pop   bp               ;
   ! pop   di               ;
   ! pop   si               ;
   ! pop   ds               ;
   ! popf                   ;
   ! mov   function, ax     ;

end function

'-------------------------------------------------------------------------------

function RedirDel (Lokal as string) public as integer

   ' Löscht einen Eintrag aus der Redirektionstabelle (NET USE.../DELETE)
   ' Es erfolgen keinerlei Fehlerprüfungen. Zurückgeliefert wird 0=Ok oder
   ' n=Betriebssystemfehlercode.

   dim Lkl as local asciiz*%lenremote ' Angabe von \\unc ist auch möglich

   Lkl = Lokal

   ! pushf                  ;
   ! push  ds               ;
   ! push  si               ;
   ! push  bp               ; eines dieser Register wird
   ! push  ss               ; von WIN95 zerstört (DOS ok)
   ! mov   ax, ss           ;
   ! lea   bx, lkl          ; Adresse von 'lkl' über SS:BX
   ! mov   si, bx           ;
   ! mov   ds, ax           ; in DS:SI laden
   ! mov   ax, &h5f04       ;
   ! int   &h21             ;
   ! jc    RedirDelEX       ;
   ! xor   ax, ax           ;
RedirDelEX:                 '
   ! pop   ss               ;
   ! pop   bp               ;
   ! pop   si               ;
   ! pop   ds               ;
   ! popf                   ;
   ! mov   function, ax     ;

end function

'-------------------------------------------------------------------------------

function RedirAddLM (Lokal  as string ,_ ' E: Lokaler Ressoucename
                     Remote as string ,_ ' E: Entfernter Res.name \\srv\share
                     UseTyp as integer,_ ' E: -1=Wildcrd 0=Dsk 1=Prt 2=Com 3=IPC
                     PassWd as string  _ ' E: Ressourcen-Password wahlweise
                    ) public as integer  '  :

   ' Fügt einen Eintrag in die Redirektionstabelle mit einer undokumentierten
   ' Funktion vom Microsoft-LAN MANAGER ein. Im Unterschied zu RedirAdd wird
   ' beim Weglassen des Schutzwortes das mit NET LOGON definierte Schutzwort
   ' verwendet, d.h. die Angabe desselben ist nicht zwingend notwendig.
   ' Um die Übergabe eines leeren Schutzwortes zu erzwingen, chr(0) übergeben.
   ' Es erfolgen keinerlei Fehlerprüfungen. Zurückgeliefert wird 0=Ok oder
   ' n=Betriebssystemfehlercode.
   ' Der Aufruf klappt nur, wenn schon angemeldet. Falls nicht, wird immer
   ' RC(0) geliefert (Passwort egal), aber nichts aufgeführt.

   dim Rmot as local string       ' dynamische Strings, da keine Längen-
   dim Pswd as local string       ' begrenzungendokumentiert sind
   dim Parm as local UseInfo1Type
   dim lp   as local integer

   Rmot        = Remote+chr$(0)
   Pswd        = ucase$(PassWd)+chr$(0)
   lp          = len(Parm)
   Parm.Locl   = Lokal
   Parm.pRmot  = strptr32(Rmot)
   Parm.UseTyp = UseTyp
   if len(PassWd) then
      Parm.pPswd = strptr32(Pswd)
   end if

   ! pushf                  ;
   ! push  ds               ;
   ! push  di               ;
   ! push  bp               ; zur
   ! push  ss               ; Sicherheit
   ! mov   ax, ss           ;
   ! lea   bx, parm         ; Adresse der Parameterstruktur
   ! mov   di, bx           ; über SS:BX
   ! mov   es, ax           ; in ES [img]http://www.powerbasic.com/support/forums/biggrin.gif[/img]I laden
   ! mov   ax, &h5f47       ;
   ! mov   bx, 1            ;
   ! mov   cx, lp           ;
   ! int   &h21             ;
   ! jc    RedirAddLMEX     ;
   ! xor   ax, ax           ;
RedirAddLMEX:               '
   ! pop   ss               ;
   ! pop   bp               ;
   ! pop   di               ;
   ! pop   ds               ;
   ! popf                   ;
   ! mov   function, ax     ;

end function

'---(Aliasname für einige alte Module, die diesen Namen erwarten)---------------

function RedirTrueName alias "fullfilename" (raw as string) local public as string

   dim   temp as local string
   dim outbuf as local asciiz*%lenbuf ' ACHTUNG: lange Buffer wg.
   dim  inbuf as local asciiz*%lenbuf ' Windows 95

   ' ACHTUNG: Windows95 löst Netzwerklaufwerke nicht mehr vernünftig auf.
   ' Daher ist hier ein Zugriff auf die Redirektionsliste vorgeschaltet.
   if len(raw) then
      ' Prüfen, ob ein REMOTE Laufwerk (NET USE) angegeben wurde (dies tut
      ' redirGetInfo implizit). Wenn ja, \\UNC-Namen zurückliefern und fertig.
      if left$(raw,2) = "\\" then
         function = raw
         exit function
      else
         temp = redirGetInfo(raw,0)
         if len(temp) then
            function = temp+mid$(raw,3)
            exit function
         end if
      end if
   end if

   ' Ansonsten wird ein LOKALER Pfad verwendet.
   ' ACHTUNG: Wird an Truename lediglich ein LW:-Buchstabe übergeben, liefert
   '          die Funktion einen Leerstring zurück, daher wird in diesem Fall
   '          ein '.' angehängt. Ungültige Laufwerke führen zur Rückgabe eines
   '          Leerstrings, nicht jedoch ungültige Pfade in gültigen Laufwerken.
   '          W95: wenn NICHTS angegeben wird, wird nur LW: zurückgegeben,
   '          daher wird hier '.' reingemogelt.
   '          W95: '...' und '....' sind auch möglich, aber '.....' führt
   '          nicht zu einem Fehler, sondern zur Rückgabe von <Lw:.....>.
   ' Siehe auch Dokus in DOS7FS1.
   if ( len(raw) = 2 and ascii(raw,2) = 58 ) or (len(raw) = 0) then
      inbuf = raw+"."
   else
      inbuf = raw
   end if

   ! pushf                  ;
   ! push  ds               ; PowerBasic benutzt das Datensegment!
   ! push  di               ;
   ! push  si               ;
   ! mov   cx, &h0001       ; CH=SUBST-Expansion-Flag CL=Steuerung Short/LongFN
   ! mov   ax, ss           ;  (0=SUBST nicht auflösen, 1=Shortfns liefern)
   ! mov   ds, ax           ;
   ! mov   es, ax           ;
   ! lea   si, inbuf        ; Adresse(Eingabe) in DS:SI
   ! lea   di, outbuf       ; Adresse(Ausgabe) in ES [img]http://www.powerbasic.com/support/forums/biggrin.gif[/img]I
   ! mov   ax, &h7160       ; NEUE Funktion
   ! stc                    ; Carryflag setzen für sicheren Fehlertrap
   ! int   &h21             ;
   ! jc    rdTruename01     ; Aufruf gescheitert -> ALTE Version versuchen
   ! xor   ax,ax            ; Signal Ok, wird leider nicht von DOS erledigt
   ! jmp   rdTruenameEX     ; und raus
rdTruename01:               '
'  ! cmp   ax, &h7100       ; sonst wahrscheinlicher Fehlergrund = DOS-Ver < 7
'  ! jne   rdTruenameEX     ; anderer Fehler aus neuer Version -> Abbruch
   ! xor   cx, cx           ;
   ! mov   ax, &h6000       ; passende ALTE Funktion aufrufen (undokumentiert)
   ! int   &h21             ;
   ! jc    rdTruenameEX     ; Aufruf gescheitert -> raus
   ! xor   ax,ax            ; wird leider nicht von DOS erledigt
rdTruenameEX:               '
   ! pop   si               ;
   ! pop   di               ;
   ! pop   ds               ; Errorcode befindet sich in AX=Funktionsergebnis
   ! popf                   ; (PowerBASIC erwartet gelöschtes DirectionFlag)
   function = outbuf        ' ACHTUNG: Hier ist das Ergebnis ein String

end function

'===============================================================================
------------------