Skip to content

Instantly share code, notes, and snippets.

@ComingNine

ComingNine/Classes_TStringList.f90 Secret

Created July 6, 2012 20:13
Show Gist options
  • Save ComingNine/4010199758d1e976b0c8 to your computer and use it in GitHub Desktop.
Save ComingNine/4010199758d1e976b0c8 to your computer and use it in GitHub Desktop.
Download ZIP
Fortran version of Delphi's TStringList.f90
Raw
Classes_TStringList.f90
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
module Classes_TStringList
use System
implicit none
private
public :: TStringListItem, TStringList
type :: TStringListItem
character(len=:), pointer :: PString => null ()
class(*), pointer :: PObject => null ()
end type
type :: TStringList
private
type(TStringListItem), dimension(:), pointer :: PList => null ()
integer(kind=I8) :: FCount = 0
integer(kind=I8) :: FCapacity = 0
logical :: FSorted = .false.
logical :: FCaseSensitive = .true.
logical :: FDuplicateAllowed = .true.
integer(kind=I1) :: FDefined = 0
character(len=1) :: FDelimiter
character(len=:), allocatable :: FLineBreak
character(len=1) :: FQuoteChar
character(len=1) :: FNameValueSeparator
contains
private
final :: DestroyStringList
final :: DestroyStringLists
procedure, pass :: ExchangeItems
procedure, pass :: Grow
procedure, pass :: QuickSort
procedure, pass :: SetCapacity
procedure, pass :: CompareStrings
procedure, pass :: InsertItem
procedure, pass, public :: SetTextStr
procedure, pass, public :: SetDelimitedText
procedure, pass, public :: GetDelimiter
procedure, pass, public :: SetDelimiter
procedure, pass, public :: GetLineBreak
procedure, pass, public :: SetLineBreak
procedure, pass, public :: GetQuoteChar
procedure, pass, public :: SetQuoteChar
procedure, pass, public :: GetNameValueSeparator
procedure, pass, public :: SetNameValueSeparator
procedure, pass, public :: GetCount
procedure, pass, public :: IsSorted
procedure, pass, public :: SetSorted
procedure, pass, public :: IsCaseSensitive
procedure, pass, public :: SetCaseSensitive
procedure, pass, public :: IsDuplicateAllowed
procedure, pass, public :: SetDuplicateAllowed
procedure, pass, public :: GetString
procedure, pass, public :: SetString
procedure, pass, public :: GetObject
procedure, pass, public :: SetObject
procedure, pass, public :: Add
procedure, pass, public :: AddObject
procedure, pass, public :: Clear
procedure, pass, public :: Delete
procedure, pass, public :: Exchange
procedure, pass, public :: Find
procedure, pass, public :: IndexOf
procedure, pass, public :: Insert
procedure, pass, public :: InsertObject
procedure, pass, public :: Sort
procedure, pass, public :: CustomSort
procedure, pass, public :: LoadFromFile
procedure, pass, public :: SaveToFile
end type TStringList
interface
function TStringListSortCompare(List, Index1, Index2)
use System
import TStringList
implicit none
integer :: TStringListSortCompare
type(TStringList), intent(in) :: List
integer(kind=I8), intent(in) :: Index1
integer(kind=I8), intent(in) :: Index2
end function TStringListSortCompare
end interface
contains
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function StringListCompareStrings (List, Index1, Index2)
integer :: StringListCompareStrings
type(TStringList), intent(in) :: List
integer(kind=I8), intent(in) :: Index1
integer(kind=I8), intent(in) :: Index2
StringListCompareStrings = List%CompareStrings(List%PList(Index1)%PString, List%PList(Index2)%PString)
end function StringListCompareStrings
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine DestroyStringList (this)
type(TStringList), intent(inout) :: this
write (*,*) '[INFO] TStringList.DestroyStringList: '
call this%Clear
end subroutine DestroyStringList
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine DestroyStringLists (this)
type(TStringList), dimension(:), intent(inout) :: this
integer(kind=I8) :: I
write (*,*) '[INFO] TStringList.DestroyStringLists: '
do I = 1, Size(this)
call this(I)%Clear
end do
end subroutine DestroyStringLists
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine ExchangeItems (this, Index1, Index2)
class(TStringList), intent(inout) :: this
integer(kind=I8) :: Index1
integer(kind=I8) :: Index2
character(len=:), pointer :: TempPStr
class(*), pointer :: TempPObj
TempPStr => this%PList(Index1)%PString
this%PList(Index1)%PString => this%PList(Index2)%PString
this%PList(Index2)%PString => TempPStr
TempPObj => this%PList(Index1)%PObject
this%PList(Index1)%PObject => this%PList(Index2)%PObject
this%PList(Index2)%PObject => TempPObj
end subroutine ExchangeItems
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine Grow (this)
class(TStringList), intent(inout) :: this
integer(kind=I8) :: Delta
Delta = 0
select case (this%FCapacity)
case (:8)
Delta = 4
case (9:64)
Delta = 16
case (65:)
Delta = this%FCapacity / 4
end select
call this%SetCapacity(this%FCapacity + Delta)
end subroutine Grow
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
recursive subroutine QuickSort (this, L, R, SCompare)
class(TStringList), intent(inout) :: this
integer, intent(inout) :: L
integer, intent(in) :: R
procedure(TStringListSortCompare) :: SCompare
integer :: I
integer :: J
integer :: P
do
I = L
J = R
P = ISHFT (L + R, -1)
do
do
if (SCompare(this, I, P) >= 0) then
exit
else
I = I + 1
end if
end do
do
if (SCompare(this, J, P) <= 0) then
exit
else
J = J - 1
end if
end do
if (I <= J) then
if (I /= J) call this%ExchangeItems(I, J)
if (P == I) then
P = J
else if (P == J) then
P = I
end if
I = I + 1
J = J - 1
end if
if (I > J) exit
end do
if (L < J) call this%QuickSort(L, J, SCompare)
L = I
if (I >= R) exit
end do
end subroutine QuickSort
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetCapacity (this, newCapacity)
class(TStringList), intent(inout) :: this
integer(kind=I8), intent(in) :: newCapacity
type(TStringListItem), dimension(:), pointer :: oldPList
integer(kind=I8) :: I
nullify (oldPList)
if ((newCapacity < this%FCount) .or. (newCapacity > MAX_LIST_SIZE)) then
write (*,*) '[ERROR] TStringList.SetCapacity: INVALID newCapacity!'
return
end if
if (newCapacity == this%FCapacity) then
return
else if (newCapacity > this%FCapacity) then
if (this%FCapacity == 0) then
allocate (this%PList(newCapacity))
else
oldPList => this%PList
allocate (this%PList(newCapacity))
do I = 1, Size(oldPList)
this%PList(I)%PString => oldPList(I)%PString
this%PList(I)%PObject => oldPList(I)%PObject
end do
deallocate (oldPList)
end if
else if (newCapacity < this%FCapacity) then
if (newCapacity == 0) then
deallocate(this%PList)
else
write (*,*) '[ERROR] TStringList.SetCapacity: UNEXPECTED newCapacity!'
return
end if
end if
this%FCapacity = newCapacity
end subroutine SetCapacity
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function CompareStrings (this, String1, String2)
use SysUtils
implicit none
integer :: CompareStrings
class(TStringList), intent(in) :: this
character(len=*), intent(in) :: String1
character(len=*), intent(in) :: String2
character(len=:), allocatable :: UString1
character(len=:), allocatable :: UString2
if (this%FCaseSensitive) then
if (String1 == String2) then
CompareStrings = 0
else if (String1 < String2) then
CompareStrings = -1
else
CompareStrings = 1
end if
else
UString1 = UpperCase (String1)
UString2 = UpperCase (String2)
if (UString1 == UString2) then
CompareStrings = 0
else if (UString1 < UString2) then
CompareStrings = -1
else
CompareStrings = 1
end if
end if
end function CompareStrings
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine InsertItem (this, Index, S, AObject)
class(TStringList), intent(inout) :: this
integer(kind=I8), intent(in) :: Index
character(len=*), intent(in) :: S
class(*), pointer :: AObject
integer :: I
if (this%FCount == this%FCapacity) call this%Grow()
if (Index <= this%FCount) then
do I = this%FCount, Index, -1
this%PList(I + 1) = this%PList(I)
end do
end if
allocate (CHARACTER(LEN=LEN(S)) :: this%PList(Index)%PString)
this%PList(Index)%PString = S
this%PList(Index)%PObject => AObject
this%FCount = this%FCount + 1
end subroutine InsertItem
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetTextStr (this, S)
use system
implicit none
class(TStringList), intent(inout) :: this
character(len=*), intent(in) :: S
integer(kind=i8) :: lenStr
integer(kind=i8) :: I
integer(kind=i8) :: J
integer(kind=i8) :: strIndex
call this%Clear();
lenStr = len(S)
I = 1
J = 1
do
if (I > lenStr) exit
if (S(I:I) == NUL) then
exit
else
J = I
do
if (I > lenStr) exit
if ((S(I:I) == NUL) .or. (S(I:I) == this%FDelimiter)) then
exit
else
I = I + 1
end if
end do
strIndex = this%Add(S(J:I-1))
if (I > lenStr) exit
if (S(I:I) == this%FDelimiter) then
I = I + 1
if (I > lenStr) exit
if (S(I:I) == NUL) then
strIndex = this%Add('')
end if
end if
end if
end do
end subroutine SetTextStr
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetDelimitedText (this, S)
use system
implicit none
class(TStringList), intent(inout) :: this
character(len=*), intent(in) :: S
integer(kind=i8) :: lenStr
integer(kind=i8) :: I
integer(kind=i8) :: J
integer(kind=i8) :: strIndex
call this%Clear();
lenStr = len(S)
I = 1
J = 1
do
if (I > lenStr) exit
if (S(I:I) == NUL) then
exit
else
J = I
do
if (I > lenStr) exit
if ((S(I:I) == NUL) .or. (S(I:I) == this%FDelimiter)) then
exit
else
I = I + 1
end if
end do
strIndex = this%Add(S(J:I-1))
if (I > lenStr) exit
if (S(I:I) == this%FDelimiter) then
I = I + 1
if (I > lenStr) exit
if (S(I:I) == NUL) then
strIndex = this%Add('')
end if
end if
end if
end do
end subroutine SetDelimitedText
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function GetDelimiter (this)
character(len=1) :: GetDelimiter
class(TStringList), intent(inout) :: this
if (.not. BTEST(this%FDefined, 0)) call this%SetDelimiter (',')
GetDelimiter = this%FDelimiter
end function GetDelimiter
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetDelimiter (this, Delimiter)
class(TStringList), intent(inout) :: this
character(len=1), intent(in) :: Delimiter
if ((this%FDelimiter /= Delimiter) .or. (.not. BTEST(this%FDefined, 0))) then
this%FDefined = IBSET(this%FDefined, 0)
this%FDelimiter = Delimiter
end if
end subroutine SetDelimiter
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function GetLineBreak (this)
character(len=:), allocatable :: GetLineBreak
class(TStringList), intent(inout) :: this
if (.not. BTEST(this%FDefined, 1)) call this%SetLineBreak (sLineBreak)
GetLineBreak = this%FLineBreak
end function GetLineBreak
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetLineBreak (this, LineBreak)
class(TStringList), intent(inout) :: this
character(len=*), intent(in) :: LineBreak
if (.not. ALLOCATED (this%FLineBreak)) then
this%FDefined = IBSET(this%FDefined, 1)
this%FLineBreak = LineBreak
else if ((this%FLineBreak /= LineBreak) .or. (.not. BTEST(this%FDefined, 1))) then
this%FDefined = IBSET(this%FDefined, 1)
this%FLineBreak = LineBreak
end if
end subroutine SetLineBreak
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function GetQuoteChar (this)
character(len=1) :: GetQuoteChar
class(TStringList), intent(inout) :: this
if (.not. BTEST(this%FDefined, 2)) call this%SetQuoteChar ('"')
GetQuoteChar = this%FQuoteChar
end function GetQuoteChar
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetQuoteChar (this, QuoteChar)
class(TStringList), intent(inout) :: this
character(len=1), intent(in) :: QuoteChar
if ((this%FQuoteChar /= QuoteChar) .or. (.not. BTEST(this%FDefined, 2))) then
this%FDefined = IBSET(this%FDefined, 2)
this%FQuoteChar = QuoteChar
end if
end subroutine SetQuoteChar
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function GetNameValueSeparator (this)
character(len=1) :: GetNameValueSeparator
class(TStringList), intent(inout) :: this
if (.not. BTEST(this%FDefined, 3)) call this%SetNameValueSeparator ('=')
GetNameValueSeparator = this%FNameValueSeparator
end function GetNameValueSeparator
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetNameValueSeparator (this, NameValueSeparator)
class(TStringList), intent(inout) :: this
character(len=1), intent(in) :: NameValueSeparator
if ((this%FNameValueSeparator /= NameValueSeparator) .or. (.not. BTEST(this%FDefined, 3))) then
this%FDefined = IBSET(this%FDefined, 3)
this%FNameValueSeparator = NameValueSeparator
end if
end subroutine SetNameValueSeparator
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function GetCount (this)
integer(kind=I8) :: GetCount
class(TStringList), intent(in) :: this
GetCount = this%FCount
end function GetCount
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function IsSorted (this)
logical :: IsSorted
class(TStringList), intent(in) :: this
IsSorted = this%FSorted
end function IsSorted
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetSorted (this, Sorted)
class(TStringList), intent(inout) :: this
logical, intent(in) :: Sorted
if (this%FSorted /= Sorted) then
if (Sorted) call this%Sort
this%FSorted = Sorted
end if
end subroutine SetSorted
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function IsCaseSensitive (this)
logical :: IsCaseSensitive
class(TStringList), intent(in) :: this
IsCaseSensitive = this%FCaseSensitive
end function IsCaseSensitive
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetCaseSensitive (this, CaseSensitive)
class(TStringList), intent(inout) :: this
logical, intent(in) :: CaseSensitive
this%FCaseSensitive = CaseSensitive
end subroutine SetCaseSensitive
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function IsDuplicateAllowed (this)
logical :: IsDuplicateAllowed
class(TStringList), intent(in) :: this
IsDuplicateAllowed = this%FDuplicateAllowed
end function IsDuplicateAllowed
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetDuplicateAllowed (this, DuplicateAllowed)
class(TStringList), intent(inout) :: this
logical, intent(in) :: DuplicateAllowed
this%FDuplicateAllowed = DuplicateAllowed
end subroutine SetDuplicateAllowed
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function GetString (this, Index)
character(len=:), allocatable :: GetString
class(TStringList), intent(in) :: this
integer, intent(in) :: Index
if ((Index < 1) .or. (Index > this%FCount)) then
write (*,'(A, I4)') '[ERROR] TStringList.GetString: List index out of bounds ', Index
return
end if
GetString = this%PList(Index)%PString
end function GetString
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetString (this, Index, S)
class(TStringList), intent(inout) :: this
integer, intent(in) :: Index
character(len=*), intent(in) :: S
if (this%FSorted) then
write (*,*) '[ERROR] TStringList.SetString: Operation not allowed on sorted list'
return
end if
if ((Index < 1) .or. (Index > this%FCount)) then
write (*,'(A, I4)') '[ERROR] TStringList.SetString: List index out of bounds ', Index
return
end if
deallocate (this%PList(Index)%PString)
allocate (CHARACTER(LEN=LEN(S)) :: this%PList(Index)%PString)
this%PList(Index)%PString = S
end subroutine SetString
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function GetObject (this, Index)
class(*), pointer :: GetObject
class(TStringList), intent(in) :: this
integer, intent(in) :: Index
if ((Index < 1) .or. (Index > this%FCount)) then
write (*,'(A, I4)') '[ERROR] TStringList.GetObject: List index out of bounds ', Index
return
end if
GetObject => this%PList(Index)%PObject
end function GetObject
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SetObject (this, Index, AObject)
class(TStringList), intent(inout) :: this
integer, intent(in) :: Index
class(*), pointer :: AObject
if (this%FSorted) then
write (*,*) '[ERROR] TStringList.SetObject: Operation not allowed on sorted list'
return
end if
if ((Index < 1) .or. (Index > this%FCount)) then
write (*,'(A, I4)') '[ERROR] TStringList.SetObject: List index out of bounds ', Index
return
end if
this%PList(Index)%PObject => AObject
end subroutine SetObject
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function Add (this, S)
integer(kind=I8) :: Add
class(TStringList), intent(inout) :: this
character(len=*), intent(in) :: S
class(*), pointer :: AObject
AObject => null ()
ADD = this%AddObject (S, AObject)
end function Add
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function AddObject (this, S, AObject)
integer(kind=I8) :: AddObject
class(TStringList), intent(inout) :: this
character(len=*), intent(in) :: S
class(*), pointer :: AObject
if (.not. this%FSorted) then
AddObject = this%FCount + 1
else
if (this%Find(S, AddObject)) then
if (.not. this%FDuplicateAllowed) return
end if
end if
call this%InsertItem (AddObject, S, AObject)
end function AddObject
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine Clear (this)
class(TStringList), intent(inout) :: this
integer(kind=I8) :: I
do I = 1, this%FCount
deallocate (this%PList(I)%PString)
end do
this%FCount = 0
call this%SetCapacity (0)
end subroutine Clear
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine Delete (this, Index)
class(TStringList), intent(inout) :: this
integer(kind=I8), intent(in) :: Index
integer(kind=I8) :: I
if ((Index < 1) .or. (Index > this%FCount)) then
write (*,'(A, I4)') '[ERROR] TStringList.Delete: List index out of bounds ', Index
return
end if
deallocate (this%PList(Index)%PString)
if (Index < this%FCount) then
do I = Index, this%FCount
this%PList(I) = this%PList(I + 1)
end do
end if
this%FCount = this%FCount - 1
end subroutine Delete
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine Exchange (this, Index1, Index2)
class(TStringList), intent(inout) :: this
integer(kind=I8), intent(in) :: Index1
integer(kind=I8), intent(in) :: Index2
if ((Index1 < 1) .or. (Index1 > this%FCount)) then
write (*,'(A, I4)') '[ERROR] TStringList.Exchange: List index out of bounds ', Index1
return
end if
if ((Index2 < 1) .or. (Index2 > this%FCount)) then
write (*,'(A, I4)') '[ERROR] TStringList.Exchange: List index out of bounds ', Index2
return
end if
call this%ExchangeItems (Index1, Index2)
end subroutine Exchange
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function Find (this, S, Index)
logical :: Find
class(TStringList), intent(in) :: this
character(len=*), intent(in) :: S
integer(kind=I8), intent(out) :: Index
integer :: L
integer :: H
integer :: I
integer :: C
Find = .false.
L = 1
H = this%FCount
do
if (L > H) exit
I = ISHFT(L + H, -1)
C = this%CompareStrings (this%PList(I)%PString, S)
if (C < 0) then
L = I + 1
else
H = I - 1
if (C == 0) then
Find = .true.
if (.not. this%FDuplicateAllowed) L = I
end if
end if
end do
Index = L
end function Find
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
function IndexOf (this, S)
integer(kind=I8) :: IndexOf
class(TStringList), intent(in) :: this
character(len=*), intent(in) :: S
if (.not. this%FSorted) then
do IndexOf = 1, this%FCount
if (this%CompareStrings(this%PList(IndexOf)%PString, S) == 0) return
end do
IndexOf = -1
else
if (.not. this%Find(S, IndexOf)) IndexOf = -1
end if
end function IndexOf
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine Insert (this, Index, S)
class(TStringList), intent(inout) :: this
integer(kind=I8), intent(in) :: Index
character(len=*), intent(in) :: S
class(*), pointer :: AObject
AObject => null ()
call this%InsertObject (Index, S, AObject)
end subroutine Insert
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine InsertObject (this, Index, S, AObject)
class(TStringList), intent(inout) :: this
integer(kind=I8), intent(in) :: Index
character(len=*), intent(in) :: S
class(*), pointer :: AObject
if (this%FSorted) then
write (*,*) '[ERROR] TStringList.InsertObject: Operation not allowed on sorted list'
return
end if
if ((Index < 1) .or. (Index > this%FCount)) then
write (*,'(A, I4)') '[ERROR] TStringList.InsertObject: List index out of bounds ', Index
return
end if
call this%InsertItem(Index, S, AObject)
end subroutine InsertObject
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine Sort (this)
class(TStringList), intent(inout) :: this
call this%CustomSort(StringListCompareStrings)
end subroutine Sort
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine CustomSort (this, Compare)
class(TStringList), intent(inout) :: this
procedure(TStringListSortCompare) :: Compare
integer(kind=I8) :: L
integer(kind=I8) :: R
L = 1
R = this%FCount
if ((.not. this%FSorted) .and. (this%FCount > 1)) then
call this%QuickSort(L, R, Compare)
end if
end subroutine CustomSort
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine LoadFromFile (this, FilePathName)
use System
implicit none
class(TStringList), intent(inout) :: this
character(len=*), intent(in) :: FilePathName
integer :: FCLX_FILEIO
integer :: iErr
character(len=256) :: msgErr
integer(kind=I8) :: fileSize
character(len=:), pointer :: pBuffer
integer(kind=I8) :: I
integer(kind=I8) :: J
integer(kind=I8) :: strIndex
nullify (pBuffer)
FCLX_FILEIO = GetThreadFileIO()
open (unit=FCLX_FILEIO, file=FilePathName, status='unknown', access='stream', form='unformatted', iostat=iErr, iomsg=msgErr)
if (iErr == 0) then
inquire (unit=FCLX_FILEIO, size=fileSize)
allocate (CHARACTER(LEN=fileSize+1) :: pBuffer)
pBuffer(fileSize+1:fileSize+1)=NUL
read (unit=FCLX_FILEIO) pBuffer(:fileSize)
close (unit=FCLX_FILEIO)
I = 1
do
select case (pBuffer(I:I))
case (NUL)
exit
case default
J = I
do
select case (pBuffer(I:I))
case (NUL, CR, LF)
exit
case default
I = I + 1
end select
end do
strIndex = this%Add(pBuffer(J:I-1))
if (pBuffer(I:I) == CR) I = I + 1
if (pBuffer(I:I) == LF) I = I + 1
end select
end do
deallocate (pBuffer)
else
write (*,*) '[ERROR]TStringList.LoadFromFile: '
write (*,*) 'msgErr is ' // msgErr
return
end if
end subroutine LoadFromFile
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
subroutine SaveToFile (this, FilePathName)
use System
implicit none
class(TStringList), intent(inout) :: this
character(len=*), intent(in) :: FilePathName
integer :: FCLX_FILEIO
integer :: iErr
character(len=256) :: msgErr
integer(kind=I8) :: fileSize
character(len=:), pointer :: pBuffer
integer(kind=I8) :: I
integer(kind=I8) :: Count
character(len=:), allocatable :: LB
integer(kind=I8) :: lenS
integer(kind=I8) :: lenLB
integer(kind=I8) :: idxBuffer
nullify (pBuffer)
Count = this%GetCount()
fileSize = 0
LB = this%GetLineBreak()
lenLB = LEN(LB)
do I = 1, Count
lenS = LEN(this%PList(I)%PString)
fileSize = fileSize + lenS + lenLB
end do
allocate (CHARACTER(LEN=fileSize+1) :: pBuffer)
pBuffer(fileSize+1:fileSize+1)=NUL
idxBuffer = 1
do I = 1, Count
lenS = LEN(this%PList(I)%PString)
if (lenS > 0) then
pBuffer(idxBuffer:idxBuffer+lenS) = this%PList(I)%PString
idxBuffer = idxBuffer + lenS
end if
if (lenLB > 0) then
pBuffer(idxBuffer:idxBuffer+lenLB) = LB
idxBuffer = idxBuffer + lenLB
end if
end do
FCLX_FILEIO = GetThreadFileIO()
open (unit=FCLX_FILEIO, file=FilePathName, status='unknown', access='stream', form='unformatted', iostat=iErr, iomsg=msgErr)
if (iErr == 0) then
write (unit=FCLX_FILEIO) pBuffer(:fileSize)
close (unit=FCLX_FILEIO)
else
write (*,*) '[ERROR]TStringList.SaveToFile: '
write (*,*) 'msgErr is ' // msgErr
return
end if
deallocate (pBuffer)
end subroutine SaveToFile
end module Classes_TStringList
!***|****1****|****2****|****3****|****4****|****5****|****6****|****7**
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment