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
|
program help_test
! note hardcoded len=k1 instead of len=: in this test is a work-around a gfortran bug in old
! pre-v8.3 versions
use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
use fpm_filesystem, only : dirname, join_path, exists
use fpm_environment, only : get_os_type, OS_WINDOWS
implicit none
integer :: i, j
integer :: be, af
character(len=:),allocatable :: path
integer :: estat, cstat
integer,parameter :: k1=132
character(len=k1) :: message
logical,allocatable :: tally(:)
!intel-bug!character(len=:),allocatable :: book1(:), book2(:)
character(len=k1),allocatable :: book1(:), book2(:)
!intel-bug!character(len=:),allocatable :: page1(:)
character(len=k1),allocatable :: page1(:)
integer :: lines
integer :: chars
! run a variety of "fpm help" variations and verify expected files are generated
character(len=*),parameter :: cmds(*) = [character(len=80) :: &
! build manual as pieces using various help commands
! debug version
' --version ',& ! verify fpm version being used
' --help > fpm_scratch_help.txt',&
' help new >> fpm_scratch_help.txt',&
' help update >> fpm_scratch_help.txt',&
' build --help >> fpm_scratch_help.txt',&
' help run >> fpm_scratch_help.txt',&
' help test >> fpm_scratch_help.txt',&
' help runner >> fpm_scratch_help.txt',&
' help install >> fpm_scratch_help.txt',&
' help list >> fpm_scratch_help.txt',&
' help help >> fpm_scratch_help.txt',&
' --version >> fpm_scratch_help.txt',&
! generate manual
' help manual > fpm_scratch_manual.txt']
!'fpm run >> fpm_scratch_help.txt',&
!'fpm run -- --list >> fpm_scratch_help.txt',&
!'fpm run -- list --list >> fpm_scratch_help.txt',&
character(len=*),parameter :: names(*)=[character(len=10) ::&
'fpm','new','update','build','run','test','runner','install','list','help']
character(len=:), allocatable :: prog
integer :: length
! FIXME: Super hacky way to get the name of the fpm executable,
! it works better than invoking fpm again but should be replaced ASAP.
call get_command_argument(0, length=length)
allocate(character(len=length) :: prog)
call get_command_argument(0, prog)
path = dirname(prog)
if (get_os_type() == OS_WINDOWS) then
prog = join_path(path, "..", "app", "fpm.exe")
if (.not.exists(prog)) then
prog = join_path(path, "..", "..", "app", "fpm.exe")
end if
else
prog = join_path(path, "..", "app", "fpm")
if (.not.exists(prog)) then
prog = join_path(path, "..", "..", "app", "fpm")
end if
end if
write(*,'(g0:,1x)')'<INFO>TEST help SUBCOMMAND STARTED'
if(allocated(tally))deallocate(tally)
allocate(tally(0))
call wipe('fpm_scratch_help.txt')
call wipe('fpm_scratch_manual.txt')
! check that output has NAME SYNOPSIS DESCRIPTION
do i=1,size(names)
write(*,*)'<INFO>check '//names(i)//' for NAME SYNOPSIS DESCRIPTION'
path= prog // ' help '//names(i)//' >fpm_scratch_help.txt'
message=''
call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message)
write(*,'(*(g0))')'<INFO>CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message)
tally=[tally,all([estat.eq.0,cstat.eq.0])]
call swallow('fpm_scratch_help.txt',page1)
if(size(page1).lt.3)then
write(*,*)'<ERROR>help for '//names(i)//' ridiculiously small'
tally=[tally,.false.]
exit
endif
!!write(*,*)findloc(page1,'NAME').eq.1
be=count(.not.tally)
tally=[tally,count(page1.eq.'NAME').eq.1]
tally=[tally,count(page1.eq.'SYNOPSIS').eq.1]
tally=[tally,count(page1.eq.'DESCRIPTION').eq.1]
af=count(.not.tally)
if(be.ne.af)then
write(*,*)'<ERROR>missing expected sections in ',names(i)
write(*,*)page1(1) ! assuming at least size 1 for debugging mingw
write(*,*)count(page1.eq.'NAME')
write(*,*)count(page1.eq.'SYNOPSIS')
write(*,*)count(page1.eq.'DESCRIPTION')
write(*,'(a)')page1
endif
write(*,*)'<INFO>have completed ',count(tally),' tests'
call wipe('fpm_scratch_help.txt')
enddo
! execute the fpm(1) commands
do i=1,size(cmds)
message=''
path= prog // cmds(i)
call execute_command_line(path,exitstat=estat,cmdstat=cstat,cmdmsg=message)
write(*,'(*(g0))')'<INFO>CMD=',path,' EXITSTAT=',estat,' CMDSTAT=',cstat,' MESSAGE=',trim(message)
tally=[tally,all([estat.eq.0,cstat.eq.0])]
enddo
! compare book written in fragments with manual
call swallow('fpm_scratch_help.txt',book1)
call swallow('fpm_scratch_manual.txt',book2)
! get rid of lines from run() which is not on stderr at the moment
book1=pack(book1,index(book1,' + build/').eq.0)
book2=pack(book1,index(book2,' + build/').eq.0)
write(*,*)'<INFO>book1 ',size(book1), len(book1)
write(*,*)'<INFO>book2 ',size(book2), len(book2)
if(size(book1).ne.size(book2))then
write(*,*)'<ERROR>manual and "debug" appended pages are not the same size'
tally=[tally,.false.]
else
if(all(book1.ne.book2))then
tally=[tally,.false.]
write(*,*)'<ERROR>manual and "debug" appended pages are not the same'
else
write(*,*)'<INFO>manual and "debug" appended pages are the same'
tally=[tally,.true.]
endif
endif
! overall size of manual
!chars=size(book2)
!lines=max(count(char(10).eq.book2),count(char(13).eq.book2))
chars=sum(len_trim(book2)) ! SUM TRIMMED LENGTH
lines=size(book2)
if( (chars.lt.12000) .or. (lines.lt.350) )then
write(*,*)'<ERROR>"debug" manual is suspiciously small, bytes=',chars,' lines=',lines
tally=[tally,.false.]
else
write(*,*)'<INFO>"debug" manual size in bytes=',chars,' lines=',lines
tally=[tally,.true.]
endif
write(*,'("<INFO>HELP TEST TALLY=",*(g0))')tally
call wipe('fpm_scratch_help.txt')
call wipe('fpm_scratch_manual.txt')
if(all(tally))then
write(*,'(*(g0))')'<INFO>PASSED: all ',count(tally),' tests passed '
else
write(*,*)'<INFO>FAILED: PASSED=',count(tally),' FAILED=',count(.not.tally)
stop 5
endif
write(*,'(g0:,1x)')'<INFO>TEST help SUBCOMMAND COMPLETE'
contains
subroutine wipe(filename)
character(len=*),intent(in) :: filename
integer :: ios
integer :: lun
character(len=k1) :: message
open(file=filename,newunit=lun,iostat=ios,iomsg=message)
if(ios.eq.0)then
close(unit=lun,iostat=ios,status='delete',iomsg=message)
if(ios.ne.0)then
write(*,*)'<ERROR>'//trim(message)
endif
else
write(*,*)'<ERROR>'//trim(message)
endif
end subroutine wipe
subroutine slurp(filename,text)
implicit none
!$@(#) M_io::slurp(3f): allocate text array and read file filename into it
character(*),intent(in) :: filename ! filename to shlep
character(len=1),allocatable,intent(out) :: text(:) ! array to hold file
integer :: nchars, igetunit, ios
character(len=k1) :: message
character(len=4096) :: local_filename
ios=0
nchars=0
message=''
open(newunit=igetunit, file=trim(filename), action="read", iomsg=message,&
&form="unformatted", access="stream",status='old',iostat=ios)
local_filename=filename
if(ios.eq.0)then ! if file was successfully opened
inquire(unit=igetunit, size=nchars)
if(nchars.le.0)then
call stderr_local( '*slurp* empty file '//trim(local_filename) )
return
endif
! read file into text array
if(allocated(text))deallocate(text) ! make sure text array not allocated
allocate ( text(nchars) ) ! make enough storage to hold file
read(igetunit,iostat=ios,iomsg=message) text ! load input file -> text array
if(ios.ne.0)then
call stderr_local( '*slurp* bad read of '//trim(local_filename)//':'//trim(message) )
endif
else
call stderr_local('*slurp* '//message)
allocate ( text(0) ) ! make enough storage to hold file
endif
close(iostat=ios,unit=igetunit) ! close if opened successfully or not
end subroutine slurp
subroutine stderr_local(message)
character(len=*) :: message
write(*,'(a)')trim(message) ! write message to standard error
end subroutine stderr_local
subroutine swallow(FILENAME,pageout)
implicit none
character(len=*),intent(in) :: FILENAME ! file to read
!intel-bug!character(len=:),allocatable,intent(out) :: pageout(:) ! page to hold file in memory
character(len=k1),allocatable,intent(out) :: pageout(:) ! page to hold file in memory
character(len=1),allocatable :: text(:) ! array to hold file in memory
call slurp(FILENAME,text) ! allocate character array and copy file into it
if(.not.allocated(text))then
write(*,*)'<ERROR>*swallow* failed to load file '//FILENAME
else ! convert array of characters to array of lines
pageout=page(text)
deallocate(text) ! release memory
endif
end subroutine swallow
function page(array) result (table)
!$@(#) M_strings::page(3fp): function to copy char array to page of text
character(len=1),intent(in) :: array(:)
!intel-bug!character(len=:),allocatable :: table(:)
character(len=k1),allocatable :: table(:)
integer :: i
integer :: linelength
integer :: length
integer :: lines
integer :: linecount
integer :: position
integer :: sz
!!character(len=1),parameter :: nl=new_line('A')
character(len=1),parameter :: nl=char(10)
character(len=1),parameter :: cr=char(13)
lines=0
linelength=0
length=0
sz=size(array)
do i=1,sz
if(array(i).eq.nl)then
linelength=max(linelength,length)
lines=lines+1
length=0
else
length=length+1
endif
enddo
if(sz.gt.0)then
if(array(sz).ne.nl)then
lines=lines+1
endif
endif
if(allocated(table))deallocate(table)
!intel-bug!allocate(character(len=linelength) :: table(lines))
allocate(character(len=k1) :: table(lines))
table=' '
linecount=1
position=1
do i=1,sz
if(array(i).eq.nl)then
linecount=linecount+1
position=1
elseif(array(i).eq.cr)then
elseif(linelength.ne.0)then
if(position.gt.len(table))then
write(*,*)'<ERROR> adding character past edge of text',table(linecount),array(i)
elseif(linecount.gt.size(table))then
write(*,*)'<ERROR> adding line past end of text',linecount,size(table)
else
table(linecount)(position:position)=array(i)
endif
position=position+1
endif
enddo
end function page
end program help_test
|
