1module fox_m_fsys_varstr
2  implicit none
3
4  private
5
6  public :: varstr
7  public :: init_varstr
8  public :: destroy_varstr
9  public :: varstr_len
10  public :: is_varstr_empty
11  public :: set_varstr_empty
12  public :: is_varstr_null
13  public :: set_varstr_null
14  public :: vs_varstr_alloc
15  public :: move_varstr_vs
16  public :: move_varstr_varstr
17  public :: str_varstr
18  public :: append_varstr
19  public :: varstr_str
20  public :: varstr_vs
21  public :: equal_varstr_str
22  public :: equal_varstr_varstr
23
24  ! Allocation step in which the data within varstr will be allocated
25  integer, parameter :: VARSTR_INIT_SIZE=1024
26  integer, parameter :: VARSTR_ALLOC_SIZE=1024
27
28  ! Variable size string type.
29  ! It is used for token field, so that it can be grown
30  ! by one character at a time without incurring constant
31  ! penalty on allocating/deallocating vs data.
32  ! See functions and subroutines at the end of this module.
33  type varstr
34    private
35    character, dimension(:), pointer :: data
36    integer :: length
37  end type varstr
38
39contains
40
41! Initialise varstr type. The string is initialised as null (i.e. invalid)
42subroutine init_varstr(vstr)
43  type(varstr), intent(inout) :: vstr
44  allocate(vstr%data(VARSTR_INIT_SIZE))
45  vstr%length = -1
46end subroutine init_varstr
47
48! Clean up memory (leaves varstr null, and drops the data field)
49subroutine destroy_varstr(vstr)
50  type(varstr), intent(inout) :: vstr
51  if (associated(vstr%data)) deallocate(vstr%data)
52  call set_varstr_null(vstr)
53end subroutine destroy_varstr
54
55! Return real length of varstr
56function varstr_len(vstr) result(l)
57  type(varstr), intent(in) :: vstr
58  integer :: l
59  if (vstr%length<0) print *, "WARNING: asking for length of null varstr"
60  l = vstr%length
61end function varstr_len
62
63
64! Make sure that varstr is at least size-n.
65! The data will be kept (copied) if keep is true (default)
66! This can be called on a null varstr, but should noty be called on
67! one which was destroyed.
68subroutine ensure_varstr_size(vstr,n,keep)
69  type(varstr), intent(inout) :: vstr
70  integer, intent(in) :: n
71  logical, optional, intent(in) :: keep
72
73  character, pointer, dimension(:) :: new_data
74  integer :: new_size, old_size
75  logical :: keep_flag
76
77  if (present(keep)) then
78    keep_flag = keep
79  else
80    keep_flag = .true.
81  end if
82
83  old_size = size(vstr%data)
84  if (n <= old_size ) return
85
86  new_size = old_size + ((n-old_size)/VARSTR_ALLOC_SIZE+1) * VARSTR_ALLOC_SIZE
87  allocate(new_data(new_size))
88
89  if (keep_flag) new_data(1:old_size) = vstr%data(1:old_size)
90
91  deallocate( vstr%data )
92  vstr%data => new_data
93end subroutine ensure_varstr_size
94
95! Returns whether varstr is empty: ""
96function is_varstr_empty(vstr)
97  type(varstr), intent(in) :: vstr
98  logical is_varstr_empty
99  is_varstr_empty = (vstr%length == 0)
100end function is_varstr_empty
101
102! Set vstr to empty string
103subroutine set_varstr_empty(vstr)
104  type(varstr), intent(inout) :: vstr
105  vstr%length = 0
106end subroutine set_varstr_empty
107
108! Returns whether varstr is null (i.e. invalid)
109function is_varstr_null(vstr)
110  type(varstr), intent(in) :: vstr
111  logical is_varstr_null
112  is_varstr_null = (vstr%length < 0)
113end function is_varstr_null
114
115! Set vstr to null
116subroutine set_varstr_null(vstr)
117  type(varstr), intent(inout) :: vstr
118  vstr%length = -1
119end subroutine set_varstr_null
120
121! Convert varstr to newly allocated array of characters
122function vs_varstr_alloc(vstr) result(vs)
123  type(varstr) :: vstr
124  character, dimension(:), pointer :: vs
125
126  if (is_varstr_null(vstr)) then
127    print *, "WARNING: Converting null varstr to string... making it empty first"
128    call set_varstr_empty(vstr)
129  end if
130
131  allocate(vs(vstr%length))
132  vs = vstr%data(1:vstr%length)
133end function vs_varstr_alloc
134
135! This call moves data from varstr to vs (i.e. vs is overwritten and vstr is made null)
136subroutine move_varstr_vs(vstr,vs)
137  type(varstr), intent(inout) :: vstr
138  character, dimension(:), pointer, intent(inout) :: vs
139
140  if (associated(vs)) deallocate(vs)
141  vs => vs_varstr_alloc(vstr)
142  call set_varstr_null(vstr)
143end subroutine move_varstr_vs
144
145! This call moves data from varstr to varstr (src becomes null)
146subroutine move_varstr_varstr(src,dst)
147  type(varstr), intent(inout) :: src
148  type(varstr), intent(inout) :: dst
149  character, dimension(:), pointer :: tmpdata
150
151  tmpdata => dst%data
152  dst%data => src%data
153  src%data => tmpdata
154  dst%length = src%length
155
156  call set_varstr_null(src)
157end subroutine move_varstr_varstr
158
159
160! Convert varstr to string type
161function str_varstr(vstr) result(s)
162  type(varstr), intent(in) :: vstr
163  character(len=vstr%length) :: s
164  integer :: i
165
166  if (is_varstr_null(vstr)) then
167    ! Can we really end-up here? Or will it blow on allocation with len=-1 ?
168    print *, "WARNING: Trying to convert null varstr to str... returning empty string"
169    s = ""
170  end if
171
172  do i = 1, vstr%length
173    s(i:i) = vstr%data(i)
174  enddo
175end function str_varstr
176
177! Append string to varstr
178subroutine append_varstr(vstr,str)
179  type(varstr), intent(inout) :: vstr
180  character(len=*), intent(in) :: str
181  character, dimension(:), pointer :: tmp
182  integer :: i
183
184  if (is_varstr_null(vstr)) then
185    print *, "WARNING: Trying to append to null varstr... making it empty first"
186    call set_varstr_empty(vstr)
187  end if
188
189  call ensure_varstr_size(vstr,vstr%length+len(str))
190
191  ! Note: on a XML file with very large tokens, this loop
192  ! is consistently faster than equivalent 'transfer' intrinsic
193  do i=1,len(str)
194    vstr%data(vstr%length+i) = str(i:i)
195  end do
196  vstr%length = vstr%length + len(str)
197end subroutine append_varstr
198
199! Convert string to varstr in place
200subroutine varstr_str(vstr,str)
201  type(varstr), intent(inout) :: vstr
202  character(len=*), intent(in) :: str
203  integer :: i
204
205  call ensure_varstr_size(vstr,len(str),.false.)
206  do i=1,len(str)
207    vstr%data(i) = str(i:i)
208  end do
209  vstr%length = len(str)
210end subroutine varstr_str
211
212! Convert character array to varstr in place
213subroutine varstr_vs(vstr,vs)
214  type(varstr), intent(inout) :: vstr
215  character, dimension(:), intent(in) :: vs
216
217  call ensure_varstr_size(vstr,size(vs),.false.)
218
219  vstr%length = size(vs)
220  vstr%data(1:size(vs)) = vs
221end subroutine varstr_vs
222
223! Compare varstr to str (true if equal)
224function equal_varstr_str(vstr,str) result(r)
225  type(varstr), intent(in) :: vstr
226  character(len=*) :: str
227  logical :: r
228
229  integer :: i
230
231  r = .false.
232  if ( len(str) /= varstr_len(vstr) ) return
233  do i=1,len(str)
234    if ( str(i:i) /= vstr%data(i) ) return
235  end do
236  r = .true.
237end function equal_varstr_str
238
239! Compare varstr to varstr (true if equal)
240function equal_varstr_varstr(vstr1,vstr2) result(r)
241  type(varstr), intent(in) :: vstr1, vstr2
242  logical :: r
243
244  integer :: i
245
246  r = .false.
247  if ( varstr_len(vstr1) /= varstr_len(vstr2) ) return
248  do i=1,varstr_len(vstr1)
249    if ( vstr1%data(i) /= vstr2%data(i) ) return
250  end do
251  r = .true.
252end function equal_varstr_varstr
253
254end module fox_m_fsys_varstr
255