[SRC] cListLink (Lista enlazada... mejor dicho bloques enlazados.)

[BlackZeroX]

Estoy un poco aburrido y me e puesto a hacer esto:

Esta clase la he creado para tratar un poco las listas enlazadas de la manera:

Elemento 1, Elemento 2, ... , Elemento N

Es decir que la clase EMULA las listas enlazadas que libremente se pueden escribir con punteros en C/C++ pero en listas lineales.

* No estan enlazadas en forma de arbol.

De tal modo que Dejo de sustitucion a  Redim Preserve   NO en todos los casos Ojo.

Ventajas:

* Asigna memoria dependiendo sin cambiar la hubicacion de los demas elementos ( agregacion rapida de elementos ).
* Se trata a la memoria como un bloque de bytes como cualquier otro (Generico).

Desventajas:

* No se puede usar Copymemory para copiar a mas de 1 elemento...
* Solo es utilizable para casos contados...

cListLink.cls

Código (vb) [Seleccionar] Expandir



'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandecido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
'   //                                                         //
'   // * Esta es una lista de 1 solo Orden... es decir no es   //
'   // de ordenamiento en arbol...                             //
'   //                                                         //
'   /////////////////////////////////////////////////////////////
'   // http://infrangelux.hostei.com/index.php?option=com_content&view=article&id=29:clistlink&catid=15:catmoduloscls&Itemid=24
'   /////////////////////////////////////////////////////////////

Option Explicit

Private Const MEM_DECOMMIT = &H4000
Private Const MEM_RELEASE = &H8000
Private Const MEM_COMMIT = &H1000
Private Const MEM_RESERVE = &H2000
Private Const MEM_RESET = &H80000
Private Const MEM_TOP_DOWN = &H100000
Private Const PAGE_READONLY = &H2
Private Const PAGE_READWRITE = &H4
Private Const PAGE_EXECUTE = &H10
Private Const PAGE_EXECUTE_READ = &H20
Private Const PAGE_EXECUTE_READWRITE = &H40
Private Const PAGE_GUARD = &H100
Private Const PAGE_NOACCESS = &H1
Private Const PAGE_NOCACHE = &H200
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal ByteLen As Long)
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function VirtualLock Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long) As Long
Private Declare Function VirtualUnlock Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long) As Long
'Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long
'Private Declare Function IsBadWritePtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long
'Private Declare Function IsBadStringPtr Lib "kernel32" Alias "IsBadStringPtrA" (ByVal lpsz As Long, ByVal ucchMax As Long) As Long
'Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpStringDest As String, ByVal lpStringSrc As Long) As Long
'Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (ByVal Destination As Long, ByVal Length As Long)

Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal RetVal As Long)

Dim pfirst          As Long
Dim pLast           As Long
Dim lSize           As Long

Const SIZEAB        As Long = &H8
Const BEFORESIZE    As Long = &H0
Const AFTERSIZE     As Long = (BEFORESIZE + &H4)

Public Function release(ByVal pStream As Long) As Boolean
Dim lSizeF      As Long
Dim pAfter       As Long
Dim pBefore     As Long
   If (pStream = &H0) Then Exit Function
   lSizeF = (SIZEAB + lSize)
   pAfter = after(pStream)
   pBefore = before(pStream)
   VirtualUnlock pStream, lSizeF
   VirtualFree pStream, lSizeF, MEM_DECOMMIT
   VirtualFree pStream, 0, MEM_RELEASE
   If (pAfter) Then putBefore pAfter, pBefore
   If (pBefore) Then putAfter pBefore, pAfter
   If (pStream = pfirst) Then pfirst = pBefore
   If (pStream = pLast) Then pLast = pAfter
   release = True
End Function

Public Function getPtr(ByVal lIndex As Long) As Long
'   //  Retorna el puntero del elemento indicado en lIndex.
Dim pTmp            As Long
Dim i               As Long
   pTmp = first()
   Do Until (pTmp = &H0)
       i = (i + &H1)
       If (i > lIndex) Then Exit Do
       pTmp = after(pTmp)
   Loop
   getPtr = pTmp
End Function

Public Property Get size() As Long
   size = lSize
End Property

Public Property Let size(ByVal lVal As Long)
   Call clear
   lSize = lVal
End Property

Friend Sub writeStream(ByVal pStruct As Long, ByVal pData As Long)
'   //  Setea los valores en el bloque de la memoria de la lista enlazada.
   CopyMemory pStruct, pData, lSize
End Sub

Friend Function readStream(ByVal pStruct As Long, ByVal pData As Long)
'   //  Retorna los valores del bloque de la lista enlazada a una bloque.
   CopyMemory pData, pStruct, lSize
End Function


'   //  Estas funciones otienen el 1er y ultimo elemento agregado a la lista.
Friend Function first() As Long
   first = pfirst
End Function

Friend Function last() As Long
   last = pLast
End Function


'   //  funciones iteradoras.
Friend Function after(ByVal pStruct As Long) As Long    '   //  Rectorna del puntero al bloque que se agrego despues de pStruct
Dim pTmp            As Long
   If (pStruct = &H0) Then Exit Function
   GetMem4 ByVal (pStruct + lSize + AFTERSIZE), VarPtr(pTmp)
   after = pTmp
End Function

Friend Function before(ByVal pStruct As Long) As Long   '   //  Rectorna del puntero al bloque anteriormente agregado de pStruct
Dim pTmp            As Long
   If (pStruct = &H0) Then Exit Function
   GetMem4 ByVal (pStruct + lSize + BEFORESIZE), VarPtr(pTmp)
   before = pTmp
End Function

Friend Function addNew() As Long                        '   //  Agrega un nuevo bloque y lo enlaza.
Dim lSizeF      As Long
Dim pNew        As Long
   lSizeF = (SIZEAB + lSize)
   pNew = VirtualAlloc(ByVal 0&, lSizeF, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
   VirtualLock pNew, lSizeF
   ZeroMemory pNew, lSizeF                             '   //  llenamos de 0 el bloque.
   If (pLast) Then                                     '   //  Actualizamos el ultimo...
       putBefore pNew, pLast
       putAfter pLast, pNew
   End If
   If (pfirst = &H0) Then pfirst = pNew
   pLast = pNew
   addNew = pNew
End Function

Private Sub putAfter(ByVal pStruct As Long, ByVal pAfter As Long)
   If (pStruct = &H0) Then Exit Sub
   PutMem4 (pStruct + lSize + AFTERSIZE), pAfter        '   //  pNew.After
End Sub

Private Sub putBefore(ByVal pStruct As Long, ByVal pBefore As Long)
   If (pStruct = &H0) Then Exit Sub
   PutMem4 (pStruct + lSize + BEFORESIZE), pBefore     '   //  pNOW.BEFORE
End Sub

Public Function clear() As Long                         '   //  Libera la memoria asignada y retorna la cantidad liberada en bytes.
Dim lSizeRet        As Long
Dim pTmp            As Long
   pTmp = first()      '   //  Seteamos el 1ro.
   Do Until (release(pTmp) = False)
       lSizeRet = (lSizeRet + lSize + SIZEAB)
       pTmp = first()
   Loop
   clear = lSizeRet
End Function

Private Sub Class_Terminate()
   Call clear
End Sub



Ejemplo de uso

Código (Vb) [Seleccionar] Expandir



Option Explicit

Private Type DATOSPERSONALES
   edad        As Long
   categoria   As Long
   nombre      As String * 20
   apellidoP   As String * 10
   apellidoM   As String * 10
End Type

Private Sub Form_Load()
Dim oList       As cListLink
Dim tDatosP     As DATOSPERSONALES      '   //  Plantilla...
Dim pElement    As Long                 '   //  Puntero al elemento...
   
   Set oList = New cListLink
   
   oList.size = LenB(tDatosP)                                  '   //  Tamaño de la estructura (bloque de datos).
   
   With tDatosP
       .edad = 22
       .categoria = 1
       .nombre = "Miguel Angel"
       .apellidoP = "Ortega"
       .apellidoM = "Avila"
   End With
   Call oList.writeStream(oList.addNew(), VarPtr(tDatosP))     '   //  Escribimos la estructura en una lista enlazada.
   
   With tDatosP
       .edad = 42
       .categoria = 2
       .nombre = "Angel"
       .apellidoP = "Ortega"
       .apellidoM = "Hernandez"
   End With
   Call oList.writeStream(oList.addNew(), VarPtr(tDatosP))     '   //  Escribimos la estructura en una lista enlazada.
   
   With tDatosP
       .edad = 19
       .categoria = 2
       .nombre = "Maria Luisa"
       .apellidoP = "Beltran"
       .apellidoM = "Ramirez"
   End With
   Call oList.writeStream(oList.addNew(), VarPtr(tDatosP))     '   //  Escribimos la estructura en una lista enlazada.
   
   
   'Call oList.release(oList.before(oList.firts()))             '   //  Liberamos el 2 registro ("Angel Ortega Hernandez"), para eso obtenemos el 1 elemento y obtenemos el siguiente elemento con before...
   Call oList.release(oList.getPtr(1))                         '   //  Eliminamos el elemento con Index 1
   
   '   //  Retornamos los elementos...
   
   pElement = oList.first()
   
   Do Until (pElement = &H0)
       
       oList.readStream pElement, VarPtr(tDatosP)
       With tDatosP
           Debug.Print "Nombre:", .nombre
           Debug.Print "ApellidoP:", .apellidoP
           Debug.Print "ApellidoM:", .apellidoM
           Debug.Print "Edad:", .edad
           Debug.Print "Categoria:", .categoria
           Debug.Print
           Debug.Print
           Debug.Print
       End With
       pElement = oList.after(pElement)
   Loop
   
   Set oList = Nothing
   
End Sub



Temibles Lunas!¡.