summaryrefslogtreecommitdiffstats
path: root/fortran/test/tH5E_F03.F90
blob: f5ed9fbc8c2fb150572f5c7ddcf58f42d0664bf8 (plain)
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
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
!****h* root/fortran/test/tH5E_F03.f90
!
! NAME
!  tH5E_F03.f90
!
! FUNCTION
!  Test FORTRAN HDF5 H5E APIs which are dependent on FORTRAN 2003
!  features.
!
! COPYRIGHT
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!   Copyright by The HDF Group.                                               *
!   All rights reserved.                                                      *
!                                                                             *
!   This file is part of HDF5.  The full HDF5 copyright notice, including     *
!   terms governing use, modification, and redistribution, is contained in    *
!   the COPYING file, which can be found at the root of the source code       *
!   distribution tree, or in https://www.hdfgroup.org/licenses.               *
!   If you do not have access to either file, you may request a copy from     *
!   help@hdfgroup.org.                                                        *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
! USES
!  liter_cb_mod
!
! CONTAINS SUBROUTINES
!  test_error
!
!*****

#include <H5config_f.inc>

! *****************************************
! ***        H 5 E   T E S T S
! *****************************************
MODULE test_my_hdf5_error_handler

  USE HDF5
  USE TH5_MISC
  USE TH5_MISC_GEN

CONTAINS

!***************************************************************
!**
!**  my_hdf5_error_handler: Custom error callback routine.
!**
!***************************************************************

    INTEGER FUNCTION my_hdf5_error_handler(estack_id, data_inout) bind(C)

    ! This error function handle works with only version 2 error stack

    IMPLICIT NONE

    ! estack_id is always passed from C as: H5E_DEFAULT
    INTEGER(HID_T) :: estack_id

    ! data that was registered with H5Eset_auto_f
    ! INTEGER :: data_inout ! another option
    ! or
    TYPE(C_PTR), VALUE :: data_inout

    INTEGER, POINTER :: iunit

    CALL C_F_POINTER(data_inout, iunit)

  ! iunit = data_inout

    WRITE(iunit,'(A)') "H5Eset_auto_f_msg"
    WRITE(iunit,'(I0)') iunit

    iunit = 10*iunit

    my_hdf5_error_handler = 1 ! this is not used by the C routine

  END FUNCTION my_hdf5_error_handler

  !-------------------------------------------------------------------------
  ! Function:    custom_print_cb
  !
  ! Purpose:     Callback function to print error stack in customized way.
  !
  !-------------------------------------------------------------------------
  !
  INTEGER(C_INT) FUNCTION custom_print_cb(n, err_desc, op_data) BIND(C)

    IMPLICIT NONE

    INTEGER(SIZE_T), PARAMETER :: MSG_SIZE = 64

    INTEGER(C_INT)    :: n
    TYPE(h5e_error_t) :: err_desc
    TYPE(C_PTR)       :: op_data

    CHARACTER(LEN=MSG_SIZE) :: maj
    CHARACTER(LEN=MSG_SIZE) :: minn
    CHARACTER(LEN=MSG_SIZE) :: cls
    INTEGER(SIZE_T) :: size
    INTEGER :: msg_type

    INTEGER :: error

    CALL H5Eget_class_name_f(err_desc%cls_id, cls, error)
    IF(error .LT.0)THEN
       custom_print_cb = -1
       RETURN
    ENDIF

    IF(TRIM(cls).NE."Custom error class")THEN
       custom_print_cb = -1
       RETURN
    ENDIF

    size = 3
    CALL H5Eget_class_name_f(err_desc%cls_id, cls, error, size)
    IF(error .LT.0)THEN
       custom_print_cb = -1
       RETURN
    ENDIF
    IF(TRIM(cls).NE."Cus")THEN
       custom_print_cb = -1
       RETURN
    ENDIF

    size = 0
    CALL H5Eget_class_name_f(err_desc%cls_id, "", error, size)
    IF(error .LT.0)THEN
       custom_print_cb = -1
       RETURN
    ENDIF
    IF(size.NE.18)THEN
       custom_print_cb = -1
       RETURN
    ENDIF

    size = MSG_SIZE
    CALL H5Eget_msg_f(err_desc%maj_num, msg_type, maj, error, size)
    IF(error .LT.0)THEN
       custom_print_cb = -1
       RETURN
    ENDIF

    CALL h5eget_major_f(err_desc%maj_num, maj, size, error)
    IF("MAJOR MSG".NE.TRIM(maj))THEN
       custom_print_cb = -1
       RETURN
    ENDIF

    IF(error .LT. 0)THEN
       custom_print_cb = -1
       RETURN
    ENDIF

    CALL h5eget_minor_f(err_desc%min_num, minn, error)
    IF(error .LT. 0)THEN
       custom_print_cb = -1
       RETURN
    ENDIF
    IF("MIN MSG".NE.TRIM(minn))THEN
       custom_print_cb = -1
       RETURN
    ENDIF

    custom_print_cb = 0

  END FUNCTION custom_print_cb

END MODULE test_my_hdf5_error_handler

MODULE TH5E_F03

  USE ISO_C_BINDING
  USE test_my_hdf5_error_handler

CONTAINS

SUBROUTINE test_error(total_error)

  IMPLICIT NONE

  INTEGER :: total_error
  INTEGER(hid_t) :: file
  INTEGER :: error
  INTEGER, TARGET :: my_hdf5_error_handler_data
  INTEGER, TARGET :: iunit
  TYPE(C_PTR) :: f_ptr
  TYPE(C_FUNPTR) :: func
  CHARACTER(LEN=180) :: chr180
  INTEGER :: idx

  LOGICAL :: status

  ! set the error stack to the customized routine

  iunit = 12
  OPEN(iunit, FILE="stderr.txt")

  my_hdf5_error_handler_data = iunit

  ! ** SET THE CUSTOMIZED PRINTING OF ERROR STACK **

  ! set the customized error handling routine
  func = c_funloc(my_hdf5_error_handler)

  ! set the data sent to the customized routine
  f_ptr = c_loc(my_hdf5_error_handler_data)

  CALL H5Eset_auto_f(1, error, H5E_DEFAULT_F, func, f_ptr)
  CALL check("H5Eset_auto_f", error, total_error)

  CALL h5fopen_f("DOESNOTEXIST", H5F_ACC_RDONLY_F, file, error)
  CALL VERIFY("h5fopen_f", error, -1, total_error)

  CLOSE(iunit)

  OPEN(iunit, FILE="stderr.txt")

  READ(iunit,'(A)') chr180
  idx = INDEX(string=chr180,substring="H5Eset_auto_f_msg")
  IF(idx.EQ.0) CALL check("H5Eset_auto_f", -1, total_error)
  READ(iunit, *) idx
  CALL VERIFY("H5Eset_auto_f", idx, iunit, total_error)
  CALL VERIFY("H5Eset_auto_f", my_hdf5_error_handler_data, 10*iunit, total_error)

  CLOSE(iunit, STATUS='delete')

  CALL H5Eset_auto_f(0, error)
  CALL check("H5Eset_auto_f", error, total_error)

  CALL h5fopen_f("DOESNOTEXIST", H5F_ACC_RDONLY_F, file, error)
  CALL VERIFY("h5fopen_f", error, -1, total_error)

  INQUIRE(file="H5Etest.txt", EXIST=status)
  IF(status)THEN
     CALL VERIFY("H5Eset_auto_f", error, -1, total_error)
  ENDIF

END SUBROUTINE test_error

SUBROUTINE test_error_stack(total_error)

  IMPLICIT NONE

  INTEGER :: total_error
  INTEGER :: error
  INTEGER(HID_T) :: cls_id, major, minor, estack_id, estack_id1, estack_id2
  CHARACTER(LEN=18), TARGET :: file
  CHARACTER(LEN=18), TARGET :: func
  INTEGER          , TARGET :: line
  TYPE(C_PTR) :: ptr1, ptr2, ptr3, ptr4

  INTEGER :: msg_type
  CHARACTER(LEN=9) :: maj_mesg = "MAJOR MSG"
  CHARACTER(LEN=7) :: min_mesg = "MIN MSG"
  !file status
  LOGICAL :: status
  CHARACTER(LEN=180) :: chr180
  INTEGER :: idx
  INTEGER(SIZE_T) :: count
  CHARACTER(LEN=64), TARGET :: stderr
  TYPE(C_FUNPTR) :: func_ptr

#ifdef H5_FORTRAN_HAVE_CHAR_ALLOC
  CHARACTER(:), ALLOCATABLE :: msg_alloc
#endif

  CHARACTER(LEN=9) :: chr9
  INTEGER(SIZE_T) :: msg_size

  CALL h5eregister_class_f("Custom error class", "H5E_F03", "0.1", cls_id, error)
  CALL check("H5Eregister_class_f", error, total_error)

  CALL H5Ecreate_msg_f(cls_id, H5E_MAJOR_F, maj_mesg, major, error)
  CALL check("H5Ecreate_msg_f", error, total_error)
  CALL H5Ecreate_msg_f(cls_id, H5E_MINOR_F, min_mesg, minor, error)
  CALL check("H5Ecreate_msg_f", error, total_error)

  file = "FILE"//C_NULL_CHAR
  func = "FUNC"//C_NULL_CHAR
  line = 99

  ptr1 = C_LOC(file)
  ptr2 = C_LOC(func)
  ptr3 = C_LOC(line)

  CALL h5ecreate_stack_f(estack_id, error)
  CALL check("h5ecreate_stack_f", error, total_error)

  ! push a custom error message onto the stack
  CALL H5Epush_f(estack_id, cls_id, major, minor, "%s ERROR TEXT %s"//C_NEW_LINE, error, &
       ptr1, ptr2, ptr3, &
       arg1=ACHAR(27)//"[31m", arg2=ACHAR(27)//"[0m" )
  CALL check("H5Epush_f", error, total_error)

  CALL h5eget_num_f(estack_id, count, error)
  CALL check("h5eget_num_f", error, total_error)
  CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error)

  msg_size = 0
  CALL H5Eget_msg_f(major, msg_type, chr9, error, msg_size)
  CALL check("H5Eget_msg_f", error, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MAJOR_F, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_size, 9_SIZE_T, total_error)

  ! Check when a shorter buffer length is passed as the msg_size
  msg_size = 3
  CALL H5Eget_msg_f(major, msg_type, chr9, error, msg_size)
  CALL check("H5Eget_msg_f", error, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MAJOR_F, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_size, 9_SIZE_T, total_error)
  CALL VERIFY("H5Eget_msg_f", TRIM(chr9), maj_mesg(1:3), total_error)

  ! Check when a exact size buffer length is passed as the msg_size
  msg_size = 9
  CALL H5Eget_msg_f(major, msg_type, chr9, error, msg_size)
  CALL check("H5Eget_msg_f", error, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MAJOR_F, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_size, 9_SIZE_T, total_error)
  CALL VERIFY("H5Eget_msg_f", TRIM(chr9), maj_mesg(1:9), total_error)

  msg_size = 0
  CALL H5Eget_msg_f(minor, msg_type, chr9, error, msg_size)
  CALL check("H5Eget_msg_f", error, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error)

  ! Check when a shorter buffer length is passed as the msg_size
  msg_size = 3
  CALL H5Eget_msg_f(minor, msg_type, chr9, error, msg_size)
  CALL check("H5Eget_msg_f", error, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error)
  CALL VERIFY("H5Eget_msg_f", TRIM(chr9), min_mesg(1:3), total_error)

  ! Check when a larger buffer length is passed as the msg_size
  msg_size = 9
  CALL H5Eget_msg_f(minor, msg_type, chr9, error, msg_size)
  CALL check("H5Eget_msg_f", error, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error)
  CALL VERIFY("H5Eget_msg_f", TRIM(chr9), min_mesg(1:7), total_error)

  ! Check with an allocatable character of the exact size
#ifdef H5_FORTRAN_HAVE_CHAR_ALLOC
  msg_size = 0
  CALL H5Eget_msg_f(minor, msg_type, "", error, msg_size)
  CALL check("H5Eget_msg_f", error, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_size, 7_SIZE_T, total_error)

  ALLOCATE(CHARACTER(LEN=msg_size) :: msg_alloc)
  CALL H5Eget_msg_f(minor, msg_type, msg_alloc, error)
  CALL check("H5Eget_msg_f", error, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_type, H5E_MINOR_F, total_error)
  CALL VERIFY("H5Eget_msg_f", msg_alloc, min_mesg, total_error)
#endif

  CALL h5eprint_f(H5E_DEFAULT_F, error)
  CALL check("h5eprint_f", error, total_error)
  CALL h5eprint_f(error)
  CALL check("h5eprint_f", error, total_error)

  INQUIRE(file="H5Etest.txt", EXIST=status)
  IF(status)THEN
     OPEN(UNIT=12, FILE="H5Etest.txt", status='old')
     CLOSE(12, STATUS='delete')
  ENDIF

  CALL h5eprint_f(estack_id, error, "H5Etest.txt")
  CALL check("h5eprint_f", error, total_error)

  INQUIRE(file="H5Etest.txt", EXIST=status)
  IF(.NOT.status)THEN
     CALL check("h5eprint_f", -1, total_error)
  ELSE
     OPEN(UNIT=12, FILE="H5Etest.txt", status='old')

     READ(12,'(A)') chr180
     idx = INDEX(string=chr180,substring="Custom error class")
     IF(idx.EQ.0) CALL check("h5eprint_f1", -1, total_error)
     idx = INDEX(string=chr180,substring="H5E_F03")
     IF(idx.EQ.0) CALL check("h5eprint_f2", -1, total_error)
     idx = INDEX(string=chr180,substring="0.1")
     IF(idx.EQ.0) CALL check("h5eprint_f3", -1, total_error)

     READ(12,'(A)') chr180
     idx = INDEX(string=chr180,substring="FILE")
     IF(idx.EQ.0) CALL check("h5eprint_f4", -1, total_error)
     idx = INDEX(string=chr180,substring="99")
     IF(idx.EQ.0) CALL check("h5eprint_f5", -1, total_error)
     idx = INDEX(string=chr180,substring="FUNC")
     IF(idx.EQ.0) CALL check("h5eprint_f6", -1, total_error)
     idx = INDEX(string=chr180,substring="ERROR TEXT")
     IF(idx.EQ.0) CALL check("h5eprint_f7", -1, total_error)

     READ(12,'()')

     READ(12,"(A)") chr180
     idx = INDEX(string=chr180,substring=maj_mesg)
     IF(idx.EQ.0) CALL check("h5eprint_f", -1, total_error)

     READ(12,"(A)") chr180
     idx = INDEX(string=chr180,substring=min_mesg)
     IF(idx.EQ.0) CALL check("h5eprint_f", -1, total_error)

     CLOSE(12, STATUS='delete')
  ENDIF

  stderr = "** Print error stack in customized way **"//C_NULL_CHAR
  ptr4 = C_LOC(stderr(1:1))
  func_ptr = C_FUNLOC(custom_print_cb)

  CALL h5ewalk_f(estack_id, H5E_WALK_UPWARD_F, func_ptr, ptr4, error)
  CALL check("h5ewalk_f", error, total_error)

  CALL h5eget_num_f(estack_id, count, error)
  CALL check("h5eget_num_f", error, total_error)
  CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error)

  CALL H5Ecreate_stack_f(estack_id2, error)
  CALL check("H5Ecreate_stack_f", error, total_error)

  CALL H5Eappend_stack_f(estack_id2, estack_id, .FALSE., error)
  CALL check("H5Eappend_stack_f", error, total_error)

  CALL h5eget_num_f(estack_id2, count, error)
  CALL check("h5eget_num_f", error, total_error)
  CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error)

  ! Copy error stack, which clears the original
  CALL H5Eget_current_stack_f(estack_id1, error)
  CALL check("H5Eget_current_stack_f", error, total_error)

  CALL h5eget_num_f(estack_id1, count, error)
  CALL check("h5eget_num_f", error, total_error)
  CALL VERIFY("h5eget_num_f", count, 0_SIZE_T, total_error)

  CALL H5Eclose_stack_f(estack_id2, error)
  CALL check(" H5Eclose_stack_f", error, total_error)

  CALL H5Eclose_stack_f(estack_id, error)
  CALL check("H5Eclose_stack_f", error, total_error)

  CALL H5Eclose_stack_f(estack_id1, error)
  CALL check("H5Eclose_stack_f", error, total_error)

  CALL h5ecreate_stack_f(estack_id1, error)
  CALL check("h5ecreate_stack_f", error, total_error)

  ! push a custom error message onto the stack
  CALL H5Epush_f(estack_id1, cls_id, major, minor, "%s ERROR TEXT %s"//C_NEW_LINE, error, &
       ptr1, ptr2, ptr3, &
       arg1=ACHAR(27)//"[31m", arg2=ACHAR(27)//"[0m" )
  CALL check("H5Epush_f", error, total_error)

  CALL H5Eset_current_stack_f(estack_id1, error) ! API will also close estack_id1
  CALL check("H5Eset_current_stack_f", error, total_error)

  CALL h5eget_num_f(H5E_DEFAULT_F, count, error)
  CALL check("h5eget_num_f", error, total_error)
  CALL VERIFY("h5eget_num_f", count, 1_SIZE_T, total_error)

  CALL h5epop_f(H5E_DEFAULT_F, 1_size_t, total_error)
  CALL check("h5epop_f", error, total_error)

  CALL h5eget_num_f(H5E_DEFAULT_F, count, error)
  CALL check("h5eget_num_f", error, total_error)
  CALL VERIFY("h5eget_num_f", count, 0_SIZE_T, total_error)

  CALL H5Eclose_msg_f(major, error)
  CALL check("H5Eclose_msg_f", error, total_error)

  CALL H5Eclose_msg_f(minor, error)
  CALL check("H5Eclose_msg_f", error, total_error)

  CALL h5eunregister_class_f(cls_id, error)
  CALL check("H5Eunregister_class_f", error, total_error)

END SUBROUTINE test_error_stack

END MODULE TH5E_F03