-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathconfig.f90
372 lines (341 loc) · 16 KB
/
config.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
!=========================================================================================
! Peacemaker -- A Quantum Cluster Equilibrium Code.
!
! Copyright 2004-2006 Barbara Kirchner, University of Bonn
! Copyright 2007-2012 Barbara Kirchner, University of Leipzig
! Copyright 2013-2018 Barbara Kirchner, University of Bonn
!
! This file is part of Peacemaker.
!
! Peacemaker is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! Peacemaker is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with Peacemaker. If not, see <http://www.gnu.org/licenses/>
!=========================================================================================
! This module provides the config_t data type and associated functions, which are stored
! for parsing, storing, and accessing configuration files. A configuration file consists
! of sections, which hold records. Sections have a label, which must be unique. Records
! consist of keys and arguments. Keys must be unique within a section. Here is an example
! configuration file:
!
! # This is a comment
! [section1]
! key1 arg1 arg2
! key2
! key3 arg1 arg2 arg3
!
! [section2]
! # ...
!
! Records are stored in the record_t data type, whose public components provide access to
! the key, the number of arguments, and the arguments themselves.
!=========================================================================================
module config
use iso_varying_string
use error
implicit none
private
!=====================================================================================
! Public entities.
public :: config_t
public :: record_t
!=====================================================================================
! Represents a configuartion file.
type :: config_t
private
type(section_t), pointer :: first_section => null()
type(section_t), pointer :: last_section => null()
integer :: n = 0
contains
procedure, public :: parse => config_read
procedure, public :: has_section => config_has_section
procedure, public :: check => config_check
generic :: get_record => get_record_char, get_record_string
procedure, private :: get_record_char => config_get_record_char
procedure, private :: get_record_string => config_get_record_string
procedure, public :: get_section_label => config_get_section_label
procedure, public :: nr_sections => config_nr_sections
end type config_t
!=====================================================================================
! Represents a section.
type :: section_t
type(varying_string) :: label
type(section_t), pointer :: next_section => null()
type(record_t), pointer :: first_record => null()
type(record_t), pointer :: last_record => null()
end type section_t
!=====================================================================================
! Represents a record.
type :: record_t
private
integer, public :: nr_args
type(varying_string), dimension(:), allocatable, public :: args
type(varying_string), public :: key
logical :: unread = .true.
type(record_t), pointer :: next_record => null()
end type record_t
!=====================================================================================
! Character constants needed throughout this module.
character, parameter :: tab = achar(9)
character, parameter :: space = achar(32)
character, parameter :: comment = '#' ! comment character
character, parameter :: section_ld = '[' ! left section delimiter
character, parameter :: section_rd = ']' ! right section delimiter
!=====================================================================================
contains
!=================================================================================
! Reads a configuration file.
subroutine config_read(config, filename)
class(config_t), intent(inout) :: config
character(*), intent(in) :: filename
integer :: my_unit
integer :: ios
type(varying_string) :: line
open(newunit = my_unit, file = filename, action = 'read', status = 'old', &
iostat = ios)
if (ios /= 0) call pmk_error("could not open '" // trim(filename) // "'")
read_loop: do
call get(my_unit, line, iostat = ios)
if (ios == -1) exit read_loop
call process_line(line)
if (len(line) == 0) cycle read_loop
if (is_section(line)) then
call new_section(config, line)
else
call new_record(config, line)
end if
end do read_loop
end subroutine config_read
!=================================================================================
! Removes whitespace and comments. Converts tabs to spaces.
subroutine process_line(line)
type(varying_string), intent(inout) :: line
integer :: comment_pos
! Replace tabs with spaces.
line = replace(line, tab, space, every = .true.)
! Remove comments.
comment_pos = index(line, comment)
if (comment_pos /= 0) line = remove(line, comment_pos)
! Remove leading and trailing whitespaces.
line = adjustl(line)
line = trim(line)
end subroutine process_line
!=================================================================================
! Checks whether line is a section by scanning for left and right brackets.
! Performs syntax checks and stops if something is wrong.
function is_section(line)
type(varying_string), intent(in) :: line
logical :: is_section
integer :: ld_pos, rd_pos ! position of left and right section delimiter
! We scan for the position of the delimiters from the opposite end of the
! string. That way we can check for duplicate delimiters (syntax error) by
! checking whether the left delimiter is at the first position and
! whether the right delimiter is at the last position.
ld_pos = index(line, section_ld, back = .true.)
rd_pos = index(line, section_rd)
is_section = .false.
if (ld_pos == 0 .and. rd_pos == 0) return ! This is not a section.
! This looks like a section, check syntax.
if (ld_pos == 1 .and. rd_pos == len(line)) then
! This is a section.
is_section = .true.
else
! There's a syntax error.
call pmk_error("bad syntax in line '" // char(line) // "'")
end if
end function is_section
!=================================================================================
! Adds a new section to the configuration. Section labels must be unique. Stops if
! a duplicate is encountered.
subroutine new_section(config, line)
type(config_t), intent(inout) :: config
type(varying_string), intent(in) :: line
type(section_t), pointer :: p
type(varying_string) :: label
! Check for duplicate entries.
label = extract(line, 2, len(line)-1)
p => config%first_section
do while (associated(p))
if (p%label == label) call pmk_error("duplicate entry '[" // &
char(label) // "]'")
p => p%next_section
end do
! If we're here, there are no duplicates. Allocate space for a new section and
! initialize it.
if (.not. associated(config%first_section)) then
allocate(config%first_section)
config%last_section => config%first_section
else
allocate(config%last_section%next_section)
config%last_section => config%last_section%next_section
end if
config%last_section%label = label
config%n = config%n + 1
end subroutine new_section
!=================================================================================
! Checks whether there is a section with the given label within the configuration.
function config_has_section(config, label)
class(config_t), intent(in) :: config
character(*), intent(in) :: label
logical :: config_has_section
type(section_t), pointer :: p
p => config%first_section
do while (associated(p))
if (p%label == label) then
config_has_section = .true.
return
end if
p => p%next_section
end do
config_has_section = .false.
end function config_has_section
!=================================================================================
! Creates a new record.
subroutine new_record(config, line)
type(config_t), intent(inout) :: config
type(varying_string), intent(inout) :: line
type(section_t), pointer :: section ! pointer to current section
type(record_t), pointer :: record ! pointer to current record
type(varying_string) :: key
integer :: i
! Check whether record is associated with any section.
if (.not. associated(config%last_section)) call pmk_error("record '" // &
char(line) // "is not associated with any section")
! Get the key and check that there is no duplicate record.
call split(line, key, space)
section => config%last_section
record => section%first_record
do while (associated(record))
if (record%key == key) call pmk_error("duplicate entry '" // &
char(key) // "' in '[" // char(section%label) // "]'")
record => record%next_record
end do
! Allocate space for a new record_t data structure.
if (.not. associated(section%first_record)) then
allocate(section%first_record)
section%last_record => section%first_record
else
allocate(section%last_record%next_record)
section%last_record => section%last_record%next_record
end if
! Split the remaining line and fill the record_t data structure.
record => section%last_record
record%key = key
record%nr_args = count_words(line)
allocate(record%args(record%nr_args))
do i = 1, record%nr_args
line = adjustl(line)
call split(line, record%args(i), space)
end do
end subroutine new_record
!=================================================================================
! Count the number of words in line.
function count_words(line)
type(varying_string), intent(in) :: line
integer :: count_words
character(len(line)) :: copy
integer :: i
logical :: in_word
copy = line
count_words = 0
in_word = .false.
do i = 1, len(copy)
if (copy(i:i) == space) then
in_word = .false.
else
if (.not. in_word) then
in_word = .true.
count_words = count_words + 1
end if
end if
end do
end function count_words
!=================================================================================
! Prints unread keys.
subroutine config_check(config)
class(config_t), intent(in) :: config
type(section_t), pointer :: s
type(record_t), pointer :: r
s => config%first_section
do while (associated(s))
r => s%first_record
do while (associated(r))
if (r%unread) call pmk_warning("unknown key '" // char(r%key) // &
"' in '[" // char(s%label) // "]'")
r => r%next_record
end do
s => s%next_section
end do
end subroutine config_check
!=================================================================================
! Returns a pointer to the requested record, if it exists or null() if it does
! not. Sets the unread state of the record. A record is requested by a section
! label and a keyword.
function config_get_record_char(config, section, key)
class(config_t), intent(inout) :: config
character(*), intent(in) :: section
character(*), intent(in) :: key
type(record_t), pointer :: config_get_record_char
type(section_t), pointer :: s
type(record_t), pointer :: r
config_get_record_char => null()
s => config%first_section
do while (associated(s))
if (s%label == section) then
r => s%first_record
do while (associated(r))
if (r%key == key) then
config_get_record_char => r
r%unread = .false.
return
end if
r => r%next_record
end do
! Section labels are unique. It is pointless to continue searching.
return
end if
s => s%next_section
end do
end function config_get_record_char
!=================================================================================
! Same as above, but accepts a string as section.
function config_get_record_string(config, section, key)
class(config_t), intent(inout) :: config
type(varying_string), intent(in) :: section
character(*), intent(in) :: key
type(record_t), pointer :: config_get_record_string
config_get_record_string => config_get_record_char(config, char(section), key)
end function config_get_record_string
!=================================================================================
! Returns the section label of the n'th section. Make sure that the section
! number is valid.
function config_get_section_label(cfg, n)
class(config_t), intent(in) :: cfg
integer, intent(in) :: n
type(varying_string) :: config_get_section_label
integer :: i
type(section_t), pointer :: s
s => cfg%first_section
do i = 2, n
s => s%next_section
end do
config_get_section_label = s%label
end function config_get_section_label
!=================================================================================
! Returns the number of sections.
function config_nr_sections(cfg)
class(config_t), intent(in) :: cfg
integer :: config_nr_sections
config_nr_sections = cfg%n
end function config_nr_sections
!=================================================================================
end module config
!=========================================================================================