diff --git a/.github/workflows/ci_windows.yml b/.github/workflows/ci_windows.yml index 27d49f6c5..58be7d1fb 100644 --- a/.github/workflows/ci_windows.yml +++ b/.github/workflows/ci_windows.yml @@ -23,9 +23,8 @@ jobs: steps: - uses: actions/checkout@v2 - - name: Setup MinGW native environment + - name: Setup environment uses: msys2/setup-msys2@v2 - if: contains(matrix.msystem, 'MINGW') with: msystem: ${{ matrix.msystem }} update: false @@ -34,28 +33,10 @@ jobs: mingw-w64-${{ matrix.arch }}-gcc mingw-w64-${{ matrix.arch }}-gcc-fortran mingw-w64-${{ matrix.arch }}-python - mingw-w64-${{ matrix.arch }}-python-pip - mingw-w64-${{ matrix.arch }}-python-setuptools + mingw-w64-${{ matrix.arch }}-python-fypp mingw-w64-${{ matrix.arch }}-cmake mingw-w64-${{ matrix.arch }}-ninja - - - name: Setup msys POSIX environment - uses: msys2/setup-msys2@v2 - if: contains(matrix.msystem, 'MSYS') - with: - msystem: MSYS - update: false - install: >- - git - mingw-w64-x86_64-gcc - mingw-w64-x86_64-gcc-fortran - python - python-pip - cmake - ninja - - - name: Install fypp - run: pip install fypp + mingw-w64-x86_64-minizip-ng - run: >- PATH=$PATH:/mingw64/bin/ cmake diff --git a/CMakeLists.txt b/CMakeLists.txt index b10e1f73d..4d45cc7a0 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -48,6 +48,11 @@ if(NOT FYPP) message(FATAL_ERROR "Preprocessor fypp not found! Please install fypp following the instructions in https://fypp.readthedocs.io/en/stable/fypp.html#installing") endif() +# --- find dependencies +if (NOT TARGET "minizip::minizip") + find_package("minizip" REQUIRED) +endif() + # Custom preprocessor flags if(DEFINED CMAKE_MAXIMUM_RANK) set(fyppFlags "-DMAXRANK=${CMAKE_MAXIMUM_RANK}") diff --git a/config/cmake/Findminizip.cmake b/config/cmake/Findminizip.cmake new file mode 100644 index 000000000..813d3cd16 --- /dev/null +++ b/config/cmake/Findminizip.cmake @@ -0,0 +1,14 @@ +set(_NAME "minizip") +set(_URL "https://github.com/zlib-ng/minizip-ng") +set(_TAG "4.0.4") + +message(STATUS "Retrieving ${_NAME} from ${_URL}") +include(FetchContent) +FetchContent_Declare( + ${_NAME} + GIT_REPOSITORY ${_URL} + GIT_TAG ${_TAG} +) +FetchContent_MakeAvailable(${_NAME}) +add_library("${_NAME}::${_NAME}" INTERFACE IMPORTED) +target_link_libraries("${_NAME}::${_NAME}" INTERFACE "${_NAME}") diff --git a/example/CMakeLists.txt b/example/CMakeLists.txt index cbef7f075..1975a2185 100644 --- a/example/CMakeLists.txt +++ b/example/CMakeLists.txt @@ -1,6 +1,6 @@ macro(ADD_EXAMPLE name) add_executable(example_${name} example_${name}.f90) - target_link_libraries(example_${name} "${PROJECT_NAME}") + target_link_libraries(example_${name} ${PROJECT_NAME} "minizip::minizip") add_test(NAME ${name} COMMAND $ ${CMAKE_CURRENT_BINARY_DIR} WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) diff --git a/example/io/example_loadnpy.f90 b/example/io/example_loadnpy.f90 index b037312ec..8bdd2ec3a 100644 --- a/example/io/example_loadnpy.f90 +++ b/example/io/example_loadnpy.f90 @@ -1,5 +1,5 @@ program example_loadnpy - use stdlib_io_npy, only: load_npy + use stdlib_io_np, only: load_npy implicit none real, allocatable :: x(:, :) call load_npy('example.npy', x) diff --git a/example/io/example_savenpy.f90 b/example/io/example_savenpy.f90 index b6929f40f..df1440c42 100644 --- a/example/io/example_savenpy.f90 +++ b/example/io/example_savenpy.f90 @@ -1,5 +1,5 @@ program example_savenpy - use stdlib_io_npy, only: save_npy + use stdlib_io_np, only: save_npy implicit none real :: x(3, 2) = 1 call save_npy('example.npy', x) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 579b70c72..14512185c 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -2,6 +2,7 @@ # Create a list of the files to be preprocessed set(fppFiles + stdlib_array.fypp stdlib_ascii.fypp stdlib_bitsets.fypp stdlib_bitsets_64.fypp @@ -17,9 +18,9 @@ set(fppFiles stdlib_hash_64bit_pengy.fypp stdlib_hash_64bit_spookyv2.fypp stdlib_io.fypp - stdlib_io_npy.fypp - stdlib_io_npy_load.fypp - stdlib_io_npy_save.fypp + stdlib_io_np.fypp + stdlib_io_np_load.fypp + stdlib_io_np_save.fypp stdlib_kinds.fypp stdlib_linalg.fypp stdlib_linalg_diag.fypp @@ -101,7 +102,6 @@ set(SRC stdlib_ansi.f90 stdlib_ansi_operator.f90 stdlib_ansi_to_string.f90 - stdlib_array.f90 stdlib_codata.f90 stdlib_error.f90 stdlib_hashmap_wrappers.f90 @@ -115,6 +115,8 @@ set(SRC stdlib_specialfunctions_legendre.f90 stdlib_quadrature_gauss.f90 stdlib_stringlist_type.f90 + stdlib_io_zip.f90 + stdlib_io_minizip.f90 ${outFiles} ${outPreprocFiles} ) diff --git a/src/stdlib_array.f90 b/src/stdlib_array.f90 deleted file mode 100644 index c5e4fa004..000000000 --- a/src/stdlib_array.f90 +++ /dev/null @@ -1,68 +0,0 @@ -! SPDX-Identifier: MIT - -!> Module for index manipulation and general array handling -!> -!> The specification of this module is available [here](../page/specs/stdlib_array.html). -module stdlib_array - implicit none - private - - public :: trueloc, falseloc - -contains - - !> Version: experimental - !> - !> Return the positions of the true elements in array. - !> [Specification](../page/specs/stdlib_array.html#trueloc) - pure function trueloc(array, lbound) result(loc) - !> Mask of logicals - logical, intent(in) :: array(:) - !> Lower bound of array to index - integer, intent(in), optional :: lbound - !> Locations of true elements - integer :: loc(count(array)) - - call logicalloc(loc, array, .true., lbound) - end function trueloc - - !> Version: experimental - !> - !> Return the positions of the false elements in array. - !> [Specification](../page/specs/stdlib_array.html#falseloc) - pure function falseloc(array, lbound) result(loc) - !> Mask of logicals - logical, intent(in) :: array(:) - !> Lower bound of array to index - integer, intent(in), optional :: lbound - !> Locations of false elements - integer :: loc(count(.not.array)) - - call logicalloc(loc, array, .false., lbound) - end function falseloc - - !> Return the positions of the truthy elements in array - pure subroutine logicalloc(loc, array, truth, lbound) - !> Locations of truthy elements - integer, intent(out) :: loc(:) - !> Mask of logicals - logical, intent(in) :: array(:) - !> Truthy value - logical, intent(in) :: truth - !> Lower bound of array to index - integer, intent(in), optional :: lbound - integer :: i, pos, offset - - offset = 0 - if (present(lbound)) offset = lbound - 1 - - i = 0 - do pos = 1, size(array) - if (array(pos).eqv.truth) then - i = i + 1 - loc(i) = pos + offset - end if - end do - end subroutine logicalloc - -end module stdlib_array diff --git a/src/stdlib_array.fypp b/src/stdlib_array.fypp new file mode 100644 index 000000000..4f7aaf960 --- /dev/null +++ b/src/stdlib_array.fypp @@ -0,0 +1,120 @@ +! SPDX-Identifier: MIT + +#:include "common.fypp" +#:set RANKS = range(1, MAXRANK + 1) +#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES + +!> Module for index manipulation and general array handling +!> +!> The specification of this module is available [here](../page/specs/stdlib_array.html). +module stdlib_array + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + implicit none + private + + public :: trueloc, falseloc + + !> Helper class to allocate t_array as an abstract type. + type, public :: t_array_wrapper + class(t_array), allocatable :: array + contains + #:for k1, t1 in KINDS_TYPES + #:for rank in RANKS + generic :: allocate_array => allocate_array_${t1[0]}$${k1}$_${rank}$ + procedure :: allocate_array_${t1[0]}$${k1}$_${rank}$ + #:endfor + #:endfor + end type + + type, abstract, public :: t_array + character(:), allocatable :: name + end type + + #:for k1, t1 in KINDS_TYPES + #:for rank in RANKS + type, extends(t_array), public :: t_array_${t1[0]}$${k1}$_${rank}$ + ${t1}$, allocatable :: values${ranksuffix(rank)}$ + end type + #:endfor + #:endfor + +contains + + #:for k1, t1 in KINDS_TYPES + #:for rank in RANKS + !> Allocate an instance of the array within the wrapper. + subroutine allocate_array_${t1[0]}$${k1}$_${rank}$ (wrapper, array, stat, msg) + class(t_array_wrapper), intent(out) :: wrapper + ${t1}$, intent(in) :: array${ranksuffix(rank)}$ + integer, intent(out) :: stat + character(len=:), allocatable, intent(out) :: msg + + allocate (t_array_${t1[0]}$${k1}$_${rank}$ :: wrapper%array, stat=stat) + if (stat /= 0) then + msg = 'Failed to allocate array.'; return + end if + + select type (typed_array => wrapper%array) + class is (t_array_${t1[0]}$${k1}$_${rank}$) + typed_array%values = array + class default + msg = 'Failed to allocate values.'; stat = 1; return + end select + end + #:endfor + #:endfor + + !> Version: experimental + !> + !> Return the positions of the true elements in array. + !> [Specification](../page/specs/stdlib_array.html#trueloc) + pure function trueloc(array, lbound) result(loc) + !> Mask of logicals + logical, intent(in) :: array(:) + !> Lower bound of array to index + integer, intent(in), optional :: lbound + !> Locations of true elements + integer :: loc(count(array)) + + call logicalloc(loc, array, .true., lbound) + end + + !> Version: experimental + !> + !> Return the positions of the false elements in array. + !> [Specification](../page/specs/stdlib_array.html#falseloc) + pure function falseloc(array, lbound) result(loc) + !> Mask of logicals + logical, intent(in) :: array(:) + !> Lower bound of array to index + integer, intent(in), optional :: lbound + !> Locations of false elements + integer :: loc(count(.not. array)) + + call logicalloc(loc, array, .false., lbound) + end + + !> Return the positions of the truthy elements in array + pure subroutine logicalloc(loc, array, truth, lbound) + !> Locations of truthy elements + integer, intent(out) :: loc(:) + !> Mask of logicals + logical, intent(in) :: array(:) + !> Truthy value + logical, intent(in) :: truth + !> Lower bound of array to index + integer, intent(in), optional :: lbound + integer :: i, pos, offset + + offset = 0 + if (present(lbound)) offset = lbound - 1 + + i = 0 + do pos = 1, size(array) + if (array(pos) .eqv. truth) then + i = i + 1 + loc(i) = pos + offset + end if + end do + end +end diff --git a/src/stdlib_io_minizip.f90 b/src/stdlib_io_minizip.f90 new file mode 100644 index 000000000..a9c0b429c --- /dev/null +++ b/src/stdlib_io_minizip.f90 @@ -0,0 +1,127 @@ +!> Interface to the minizip-ng library for creating and extracting zip files. +!> +!> https://github.com/zlib-ng/minizip-ng +module stdlib_io_minizip + use, intrinsic :: iso_c_binding, only: c_char, c_ptr, c_int, c_long + implicit none + private + + integer, parameter, public :: UNZ_OK = 0 + integer, parameter, public :: UNZ_END_OF_LIST_OF_FILE = -100 + integer, parameter, public :: UNZ_ERRNO = -1 + integer, parameter, public :: UNZ_EOF = 0 + integer, parameter, public :: UNZ_PARAMERROR = -102 + integer, parameter, public :: UNZ_BADZIPFILE = -103 + integer, parameter, public :: UNZ_INTERNALERROR = -104 + integer, parameter, public :: UNZ_CRCERROR = -105 + integer, parameter, public :: UNZ_BADPASSWORD = -106 + + public :: unz_get_global_info + public :: unz_open + public :: unz_go_to_first_file + public :: unz_get_current_file_info + public :: unz_open_current_file + public :: unz_read_current_file + public :: unz_close_current_file + public :: unz_go_to_next_file + public :: unz_close + + type, bind(c), public :: unz_global_info + integer(kind=c_long) :: number_of_files + integer(kind=c_long) :: comment_size + end type + + type, bind(c), public :: unz_file_info + integer(kind=c_long) :: version + integer(kind=c_long) :: version_needed + integer(kind=c_long) :: flag + integer(kind=c_long) :: compression_method + integer(kind=c_long) :: dos_date + integer(kind=c_long) :: crc + integer(kind=c_long) :: compressed_size + integer(kind=c_long) :: uncompressed_size + integer(kind=c_long) :: size_filename + integer(kind=c_long) :: size_file_extra + integer(kind=c_long) :: size_file_comment + integer(kind=c_long) :: disk_num_start + integer(kind=c_long) :: internal_file_attributes + integer(kind=c_long) :: external_file_attributes + end type + + interface + function unz_open(path) bind(c, name='unzOpen') + import :: c_char, c_ptr + implicit none + character(kind=c_char), intent(in) :: path + type(c_ptr) :: unz_open + end + + function unz_get_global_info(file, global_info) bind(c, name='unzGetGlobalInfo') + import :: c_ptr, c_int, unz_global_info + implicit none + type(c_ptr), intent(in), value :: file + type(unz_global_info), intent(out) :: global_info + integer(kind=c_int) :: unz_get_global_info + end + + function unz_go_to_first_file(file) bind(c, name='unzGoToFirstFile') + import :: c_ptr, c_int + implicit none + type(c_ptr), intent(in), value :: file + integer(kind=c_int) :: unz_go_to_first_file + end + + function unz_get_current_file_info(file, file_info, filename, filename_buffer_size, & + & extra_field, extra_field_buffer_size, comment, comment_buffer_size) & + & bind(c, name='unzGetCurrentFileInfo') + import :: c_ptr, c_int, c_char, c_long, unz_file_info + implicit none + type(c_ptr), intent(in), value :: file + type(unz_file_info), intent(out) :: file_info + character(kind=c_char), intent(out) :: filename(*) + integer(kind=c_long), intent(in), value :: filename_buffer_size + character(kind=c_char), intent(out) :: extra_field(*) + integer(kind=c_long), intent(in), value :: extra_field_buffer_size + character(kind=c_char), intent(out) :: comment(*) + integer(kind=c_long), intent(in), value :: comment_buffer_size + integer(kind=c_int) :: unz_get_current_file_info + end + + function unz_open_current_file(file) bind(c, name='unzOpenCurrentFile') + import :: c_ptr, c_int + implicit none + type(c_ptr), intent(in), value :: file + integer(kind=c_int) :: unz_open_current_file + end + + function unz_read_current_file(file, buffer, size) bind(c, name='unzReadCurrentFile') + import :: c_ptr, c_int, c_char + implicit none + type(c_ptr), intent(in), value :: file + character(kind=c_char), intent(out) :: buffer(*) + integer(kind=c_int), intent(in), value :: size + integer(kind=c_int) :: unz_read_current_file + end + + function unz_go_to_next_file(file) bind(c, name='unzGoToNextFile') + import :: c_ptr, c_int + implicit none + type(c_ptr), intent(in), value :: file + integer(kind=c_int) :: unz_go_to_next_file + end + + function unz_close_current_file(file) bind(c, name='unzCloseCurrentFile') + import :: c_ptr, c_int + implicit none + type(c_ptr), intent(in), value :: file + integer(kind=c_int) :: unz_close_current_file + end + + function unz_close(file) bind(c, name='unzClose') + import :: c_ptr, c_int + implicit none + type(c_ptr), intent(in), value :: file + integer(kind=c_int) :: unz_close + end + end interface +end diff --git a/src/stdlib_io_npy.fypp b/src/stdlib_io_np.fypp similarity index 58% rename from src/stdlib_io_npy.fypp rename to src/stdlib_io_np.fypp index bf69a6a0c..399c4ae4b 100644 --- a/src/stdlib_io_npy.fypp +++ b/src/stdlib_io_np.fypp @@ -1,4 +1,4 @@ -! SPDX-Identifer: MIT +! SPDX-Identifier: MIT #:include "common.fypp" #:set RANKS = range(1, MAXRANK + 1) @@ -68,59 +68,94 @@ !> !> This version replaces the ASCII string (which in practice was latin1) with a !> utf8-encoded string, so supports structured types with any unicode field names. -module stdlib_io_npy - use stdlib_kinds, only : int8, int16, int32, int64, sp, dp, xdp, qp +module stdlib_io_np + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + use stdlib_array, only: t_array_wrapper implicit none private - public :: save_npy, load_npy + public :: load_npy, save_npy, load_npz, save_npz + character(len=*), parameter :: & + type_iint8 = " Version: experimental + !> + !> Load multidimensional array in npy format + !> ([Specification](../page/specs/stdlib_io.html#load_npy)) + interface load_npy + #:for k1, t1 in KINDS_TYPES + #:for rank in RANKS + module subroutine load_npy_${t1[0]}$${k1}$_${rank}$ (filename, array, iostat, iomsg) + character(len=*), intent(in) :: filename + ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ + integer, intent(out), optional :: iostat + character(len=:), allocatable, intent(out), optional :: iomsg + end + #:endfor + #:endfor + end interface !> Version: experimental !> !> Save multidimensional array in npy format !> ([Specification](../page/specs/stdlib_io.html#save_npy)) interface save_npy - #:for k1, t1 in KINDS_TYPES - #:for rank in RANKS - module subroutine save_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) + #:for k1, t1 in KINDS_TYPES + #:for rank in RANKS + module subroutine save_npy_${t1[0]}$${k1}$_${rank}$ (filename, array, iostat, iomsg) + character(len=*), intent(in) :: filename + ${t1}$, intent(in) :: array${ranksuffix(rank)}$ + integer, intent(out), optional :: iostat + character(len=:), allocatable, intent(out), optional :: iomsg + end + #:endfor + #:endfor + end interface + + !> Version: experimental + !> + !> Load multiple multidimensional arrays from a (compressed) npz file. + !> ([Specification](../page/specs/stdlib_io.html#load_npz)) + interface load_npz + module subroutine load_npz_to_arrays(filename, arrays, iostat, iomsg) character(len=*), intent(in) :: filename - ${t1}$, intent(in) :: array${ranksuffix(rank)}$ + type(t_array_wrapper), allocatable, intent(out) :: arrays(:) integer, intent(out), optional :: iostat character(len=:), allocatable, intent(out), optional :: iomsg - end subroutine save_npy_${t1[0]}$${k1}$_${rank}$ - #:endfor - #:endfor - end interface save_npy + end + end interface !> Version: experimental !> - !> Load multidimensional array in npy format - !> ([Specification](../page/specs/stdlib_io.html#load_npy)) - interface load_npy - #:for k1, t1 in KINDS_TYPES - #:for rank in RANKS - module subroutine load_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) + !> Save multidimensional arrays to a compressed or an uncompressed npz file. + !> ([Specification](../page/specs/stdlib_io.html#save_npz)) + interface save_npz + module subroutine save_npz_from_arrays(filename, arrays, compressed, iostat, iomsg) character(len=*), intent(in) :: filename - ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ + type(t_array_wrapper), intent(in) :: arrays(*) + !> If true, the file is saved in compressed format. The default is false. + logical, intent(in), optional :: compressed integer, intent(out), optional :: iostat character(len=:), allocatable, intent(out), optional :: iomsg - end subroutine load_npy_${t1[0]}$${k1}$_${rank}$ - #:endfor - #:endfor - end interface load_npy - - - character(len=*), parameter :: nl = achar(10) - - character(len=*), parameter :: & - type_iint8 = " Instance of the array to be allocated. + ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ + !> Dimensions to allocate for. + integer, intent(in) :: vshape(:) + !> Status of allocate. + integer, intent(out) :: stat + end + #:endfor + #:endfor + end interface +end diff --git a/src/stdlib_io_npy_load.fypp b/src/stdlib_io_np_load.fypp similarity index 71% rename from src/stdlib_io_npy_load.fypp rename to src/stdlib_io_np_load.fypp index 389f24cd2..843837309 100644 --- a/src/stdlib_io_npy_load.fypp +++ b/src/stdlib_io_np_load.fypp @@ -5,9 +5,12 @@ #:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES !> Implementation of loading npy files into multidimensional arrays -submodule (stdlib_io_npy) stdlib_io_npy_load - use stdlib_error, only : error_stop - use stdlib_strings, only : to_string, starts_with +submodule(stdlib_io_np) stdlib_io_np_load + use stdlib_error, only: error_stop + use stdlib_strings, only: to_string, starts_with + use stdlib_string_type, only: string_type + use stdlib_io_zip, only: unzip, zip_prefix, zip_suffix, t_unzipped_bundle, t_unzipped_file + use stdlib_array implicit none contains @@ -54,7 +57,7 @@ contains exit catch end if - call allocator(array, vshape, stat) + call allocate_array_from_shape(array, vshape, stat) if (stat /= 0) then msg = "Failed to allocate array of type '"//vtype//"' "//& & "with total size of "//to_string(product(vshape)) @@ -69,38 +72,192 @@ contains iostat = stat else if (stat /= 0) then if (allocated(msg)) then - call error_stop("Failed to read array from file '"//filename//"'"//nl//& - & msg) + call error_stop("Failed to read array from file '"//filename//"'"//nl//msg) else call error_stop("Failed to read array from file '"//filename//"'") end if end if if (present(iomsg).and.allocated(msg)) call move_alloc(msg, iomsg) - contains + end + #:endfor +#:endfor - !> Wrapped intrinsic allocate to create an allocation from a shape array - subroutine allocator(array, vshape, stat) - !> Instance of the array to be allocated - ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ - !> Dimensions to allocate for - integer, intent(in) :: vshape(:) - !> Status of allocate + #:for k1, t1 in KINDS_TYPES + #:for rank in RANKS + module subroutine allocate_array_from_shape_${t1[0]}$${k1}$_${rank}$(array, vshape, stat) + ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ + integer, intent(in) :: vshape(:) + integer, intent(out) :: stat + + allocate(array( & + #:for i in range(rank-1) + & vshape(${i+1}$), & + #:endfor + & vshape(${rank}$)), & + & stat=stat) + end + #:endfor + #:endfor + + !> Version: experimental + !> + !> Load multidimensional arrays from a compressed or uncompressed npz file. + !> ([Specification](../page/specs/stdlib_io.html#load_npz)) + module subroutine load_npz_to_arrays(filename, arrays, iostat, iomsg) + character(len=*), intent(in) :: filename + type(t_array_wrapper), allocatable, intent(out) :: arrays(:) + integer, intent(out), optional :: iostat + character(len=:), allocatable, intent(out), optional :: iomsg + + type(t_unzipped_bundle) :: unzipped_bundle + integer :: stat + character(len=:), allocatable :: msg + + call unzip(filename, unzipped_bundle, stat, msg) + if (stat == 0) then + call load_unzipped_bundle_to_arrays(unzipped_bundle, arrays, stat, msg) + else + call identify_unzip_problem(filename, stat, msg) + end if + + if (present(iostat)) then + iostat = stat + else if (stat /= 0) then + if (allocated(msg)) then + call error_stop("Failed to read arrays from file '"//filename//"'"//nl//msg) + else + call error_stop("Failed to read arrays from file '"//filename//"'") + end if + end if + + if (present(iomsg) .and. allocated(msg)) call move_alloc(msg, iomsg) + end + + subroutine load_unzipped_bundle_to_arrays(unzipped_bundle, arrays, stat, msg) + type(t_unzipped_bundle), intent(in) :: unzipped_bundle + type(t_array_wrapper), allocatable, intent(out) :: arrays(:) integer, intent(out) :: stat + character(len=:), allocatable, intent(out) :: msg + + integer :: i, io + integer, allocatable :: vshape(:) + character(len=:), allocatable :: this_type + + allocate (arrays(size(unzipped_bundle%files))) + + do i = 1, size(unzipped_bundle%files) + open (newunit=io, status='scratch', form='unformatted', access='stream', iostat=stat, iomsg=msg) + if (stat /= 0) return + + write (io, iostat=stat) unzipped_bundle%files(i)%data + if (stat /= 0) then + msg = 'Failed to write unzipped data to scratch file.' + close (io, status='delete'); return + end if - allocate(array( & - #:for i in range(rank-1) - & vshape(${i+1}$), & + rewind (io) + call get_descriptor(io, unzipped_bundle%files(i)%name, this_type, vshape, stat, msg) + if (stat /= 0) return + + select case (this_type) + #:for k1, t1 in KINDS_TYPES + case (type_${t1[0]}$${k1}$) + select case (size(vshape)) + #:for rank in RANKS + case (${rank}$) + block + ${t1}$, allocatable :: array${ranksuffix(rank)}$ + + call allocate_array_from_shape(array, vshape, stat) + if (stat /= 0) then + msg = "Failed to allocate array of type '"//this_type//"'."; return + end if + + read (io, iostat=stat) array + if (stat /= 0) then + msg = "Failed to read array of type '"//this_type//"' "//& + & 'with total size of '//to_string(product(vshape)); return + end if + + call arrays(i)%allocate_array(array, stat, msg) + if (stat /= 0) then + msg = "Failed to allocate array of type '"//this_type//"' "//& + & 'with total size of '//to_string(product(vshape)); return + end if + + arrays(i)%array%name = unzipped_bundle%files(i)%name + end block + #:endfor + case default + stat = 1; msg = 'Unsupported rank for array of type '//this_type//': '// & + & to_string(size(vshape))//'.'; return + end select #:endfor - & vshape(${rank}$)), & - & stat=stat) + case default + stat = 1; msg = 'Unsupported array type: '//this_type//'.'; return + end select - end subroutine allocator + close (io, status='delete') + if (stat /= 0) return + end do + end - end subroutine load_npy_${t1[0]}$${k1}$_${rank}$ - #:endfor -#:endfor + !> Open file and try to identify the cause of the error that occurred during unzip. + subroutine identify_unzip_problem(filename, stat, msg) + character(len=*), intent(in) :: filename + integer, intent(inout) :: stat + character(len=:), allocatable, intent(inout) :: msg + + logical :: exists + integer :: io_unit, prev_stat + character(len=:), allocatable :: prev_msg + + ! Keep track of the previous status and message in case no reason can be found. + prev_stat = stat + if (allocated(msg)) call move_alloc(msg, prev_msg) + + inquire (file=filename, exist=exists) + if (.not. exists) then + stat = 1; msg = 'File does not exist: '//filename//'.'; return + end if + open (newunit=io_unit, file=filename, form='unformatted', access='stream', & + & status='old', action='read', iostat=stat, iomsg=msg) + if (stat /= 0) return + + call verify_header(io_unit, stat, msg) + if (stat /= 0) return + ! Restore previous status and message if no reason could be found. + stat = prev_stat; msg = 'Failed to unzip file: '//filename//nl//prev_msg + end + + subroutine verify_header(io_unit, stat, msg) + integer, intent(in) :: io_unit + integer, intent(out) :: stat + character(len=:), allocatable, intent(out) :: msg + + integer :: file_size + character(len=len(zip_prefix)) :: header + + inquire (io_unit, size=file_size) + if (file_size < len(zip_suffix)) then + stat = 1; msg = 'File is too small to be an npz file.'; return + end if + + read (io_unit, iostat=stat) header + if (stat /= 0) then + msg = 'Failed to read header from file'; return + end if + + if (header == zip_suffix) then + stat = 1; msg = 'Empty npz file.'; return + end if + + if (header /= zip_prefix) then + stat = 1; msg = 'Not an npz file.'; return + end if + end !> Read the npy header from a binary file and retrieve the descriptor string. subroutine get_descriptor(io, filename, vtype, vshape, stat, msg) @@ -125,7 +282,7 @@ contains ! stat should be zero if no error occurred stat = 0 - + read(io, iostat=stat) header if (stat /= 0) return @@ -169,7 +326,7 @@ contains if (.not.fortran_order) then vshape = [(vshape(i), i = size(vshape), 1, -1)] end if - end subroutine get_descriptor + end !> Parse the first eight bytes of the npy header to verify the data @@ -215,7 +372,7 @@ contains & "'"//to_string(major)//"."//to_string(minor)//"'" return end if - end subroutine parse_header + end !> Parse the descriptor in the npy header. This routine implements a minimal !> non-recursive parser for serialized Python dictionaries. @@ -368,7 +525,7 @@ contains & "1 | " // input // nl // & & " |" // repeat(" ", first) // repeat("^", last - first + 1) // nl // & & " |" - end function make_message + end !> Parse a tuple of integers into an array of integers subroutine parse_tuple(input, pos, tuple, stat, msg) @@ -428,7 +585,7 @@ contains return end select end do - end subroutine parse_tuple + end !> Get the next allowed token subroutine next_token(input, pos, token, allowed_token, stat, msg) @@ -460,7 +617,7 @@ contains exit end if end do - end subroutine next_token + end !> Tokenize input string subroutine get_token(input, pos, token) @@ -532,8 +689,8 @@ contains token = token_type(pos, pos, invalid) end select - end subroutine get_token + end - end subroutine parse_descriptor + end -end submodule stdlib_io_npy_load +end diff --git a/src/stdlib_io_np_save.fypp b/src/stdlib_io_np_save.fypp new file mode 100644 index 000000000..b6fffbcc3 --- /dev/null +++ b/src/stdlib_io_np_save.fypp @@ -0,0 +1,154 @@ +! SPDX-Identifier: MIT + +#:include "common.fypp" +#:set RANKS = range(1, MAXRANK + 1) +#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES + +!> Implementation of saving multidimensional arrays to npy files +submodule(stdlib_io_np) stdlib_io_np_save + use stdlib_error, only: error_stop + use stdlib_strings, only: to_string + implicit none + +contains + + !> Generate magic header string for npy format + pure function magic_header(major, minor) result(str) + !> Major version of npy format + integer, intent(in) :: major + !> Minor version of npy format + integer, intent(in) :: minor + !> Magic string for npy format + character(len=8) :: str + + str = magic_number//magic_string//achar(major)//achar(minor) + end + + !> Generate header for npy format + pure function npy_header(vtype, vshape) result(str) + !> Type of variable + character(len=*), intent(in) :: vtype + !> Shape of variable + integer, intent(in) :: vshape(:) + !> Header string for npy format + character(len=:), allocatable :: str + + integer, parameter :: len_v10 = 8 + 2, len_v20 = 8 + 4, block_size = 64 + + str = & + "{'descr': '"//vtype// & + "', 'fortran_order': True, 'shape': "// & + shape_str(vshape)//", }" + + if (len(str) + len_v10 >= 65535) then + str = str// & + & repeat(" ", block_size - mod(len(str) + len_v20 + 1, block_size))//nl + str = magic_header(2, 0)//to_bytes_i4(int(len(str)))//str + else + str = str// & + & repeat(" ", block_size - mod(len(str) + len_v10 + 1, block_size))//nl + str = magic_header(1, 0)//to_bytes_i2(int(len(str)))//str + end if + end + + !> Write integer as byte string in little endian encoding + pure function to_bytes_i4(val) result(str) + !> Integer value to convert to bytes + integer, intent(in) :: val + !> String of bytes + character(len=4) :: str + + str = achar(mod(val, 256**1))// & + & achar(mod(val, 256**2)/256**1)// & + & achar(mod(val, 256**3)/256**2)// & + & achar(val/256**3) + end + + !> Write integer as byte string in little endian encoding, 2-byte truncated version + pure function to_bytes_i2(val) result(str) + !> Integer value to convert to bytes + integer, intent(in) :: val + !> String of bytes + character(len=2) :: str + + str = achar(mod(val, 2**8))// & + & achar(mod(val, 2**16)/2**8) + end + + !> Print array shape as tuple of int + pure function shape_str(vshape) result(str) + !> Shape of variable + integer, intent(in) :: vshape(:) + !> Shape string for npy format + character(len=:), allocatable :: str + + integer :: i + + str = "(" + do i = 1, size(vshape) + str = str//to_string(vshape(i))//", " + end do + str = str//")" + end + + #:for k1, t1 in KINDS_TYPES + #:for rank in RANKS + !> Save ${rank}$-dimensional array in npy format + module subroutine save_npy_${t1[0]}$${k1}$_${rank}$ (filename, array, iostat, iomsg) + !> Name of the npy file to load from + character(len=*), intent(in) :: filename + !> Array to be loaded from the npy file + ${t1}$, intent(in) :: array${ranksuffix(rank)}$ + !> Error status of loading, zero on success + integer, intent(out), optional :: iostat + !> Associated error message in case of non-zero status code + character(len=:), allocatable, intent(out), optional :: iomsg + + character(len=*), parameter :: vtype = type_${t1[0]}$${k1}$ + integer :: io, stat + + open (newunit=io, file=filename, form="unformatted", access="stream", iostat=stat) + if (stat == 0) then + write (io, iostat=stat) npy_header(vtype, shape(array)) + end if + if (stat == 0) then + write (io, iostat=stat) array + end if + close (io, iostat=stat) + + if (present(iostat)) then + iostat = stat + else if (stat /= 0) then + call error_stop("Failed to write array to file '"//filename//"'") + end if + + if (present(iomsg)) then + if (stat /= 0) then + iomsg = "Failed to write array to file '"//filename//"'" + end if + end if + end + #:endfor + #:endfor + + !> Version: experimental + !> + !> Save multidimensional arrays to a compressed or an uncompressed npz file. + !> ([Specification](../page/specs/stdlib_io.html#save_npz)) + module subroutine save_npz_from_arrays(filename, arrays, compressed, iostat, iomsg) + character(len=*), intent(in) :: filename + type(t_array_wrapper), intent(in) :: arrays(*) + !> If true, the file is saved in compressed format. The default is false. + logical, intent(in), optional :: compressed + integer, intent(out), optional :: iostat + character(len=:), allocatable, intent(out), optional :: iomsg + + logical :: is_compressed + + if (present(compressed)) then + is_compressed = compressed + else + is_compressed = .false. + end if + end +end diff --git a/src/stdlib_io_npy_save.fypp b/src/stdlib_io_npy_save.fypp deleted file mode 100644 index 706c3cd90..000000000 --- a/src/stdlib_io_npy_save.fypp +++ /dev/null @@ -1,139 +0,0 @@ -! SPDX-Identifer: MIT - -#:include "common.fypp" -#:set RANKS = range(1, MAXRANK + 1) -#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES - -!> Implementation of saving multidimensional arrays to npy files -submodule (stdlib_io_npy) stdlib_io_npy_save - use stdlib_error, only : error_stop - use stdlib_strings, only : to_string - implicit none - -contains - - - !> Generate magic header string for npy format - pure function magic_header(major, minor) result(str) - !> Major version of npy format - integer, intent(in) :: major - !> Minor version of npy format - integer, intent(in) :: minor - !> Magic string for npy format - character(len=8) :: str - - str = magic_number // magic_string // achar(major) // achar(minor) - end function magic_header - - - !> Generate header for npy format - pure function npy_header(vtype, vshape) result(str) - !> Type of variable - character(len=*), intent(in) :: vtype - !> Shape of variable - integer, intent(in) :: vshape(:) - !> Header string for npy format - character(len=:), allocatable :: str - - integer, parameter :: len_v10 = 8 + 2, len_v20 = 8 + 4, block_size = 64 - - str = & - "{'descr': '"//vtype//& - "', 'fortran_order': True, 'shape': "//& - shape_str(vshape)//", }" - - if (len(str) + len_v10 >= 65535) then - str = str // & - & repeat(" ", block_size - mod(len(str) + len_v20 + 1, block_size)) // nl - str = magic_header(2, 0) // to_bytes_i4(int(len(str))) // str - else - str = str // & - & repeat(" ", block_size - mod(len(str) + len_v10 + 1, block_size)) // nl - str = magic_header(1, 0) // to_bytes_i2(int(len(str))) // str - end if - end function npy_header - - !> Write integer as byte string in little endian encoding - pure function to_bytes_i4(val) result(str) - !> Integer value to convert to bytes - integer, intent(in) :: val - !> String of bytes - character(len=4) :: str - - str = achar(mod(val, 256**1)) // & - & achar(mod(val, 256**2) / 256**1) // & - & achar(mod(val, 256**3) / 256**2) // & - & achar(val / 256**3) - end function to_bytes_i4 - - - !> Write integer as byte string in little endian encoding, 2-byte truncated version - pure function to_bytes_i2(val) result(str) - !> Integer value to convert to bytes - integer, intent(in) :: val - !> String of bytes - character(len=2) :: str - - str = achar(mod(val, 2**8)) // & - & achar(mod(val, 2**16) / 2**8) - end function to_bytes_i2 - - - !> Print array shape as tuple of int - pure function shape_str(vshape) result(str) - !> Shape of variable - integer, intent(in) :: vshape(:) - !> Shape string for npy format - character(len=:), allocatable :: str - - integer :: i - - str = "(" - do i = 1, size(vshape) - str = str//to_string(vshape(i))//", " - enddo - str = str//")" - end function shape_str - - -#:for k1, t1 in KINDS_TYPES - #:for rank in RANKS - !> Save ${rank}$-dimensional array in npy format - module subroutine save_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) - !> Name of the npy file to load from - character(len=*), intent(in) :: filename - !> Array to be loaded from the npy file - ${t1}$, intent(in) :: array${ranksuffix(rank)}$ - !> Error status of loading, zero on success - integer, intent(out), optional :: iostat - !> Associated error message in case of non-zero status code - character(len=:), allocatable, intent(out), optional :: iomsg - - character(len=*), parameter :: vtype = type_${t1[0]}$${k1}$ - integer :: io, stat - - open(newunit=io, file=filename, form="unformatted", access="stream", iostat=stat) - if (stat == 0) then - write(io, iostat=stat) npy_header(vtype, shape(array)) - end if - if (stat == 0) then - write(io, iostat=stat) array - end if - close(io, iostat=stat) - - if (present(iostat)) then - iostat = stat - else if (stat /= 0) then - call error_stop("Failed to write array to file '"//filename//"'") - end if - - if (present(iomsg)) then - if (stat /= 0) then - iomsg = "Failed to write array to file '"//filename//"'" - end if - end if - end subroutine save_npy_${t1[0]}$${k1}$_${rank}$ - #:endfor -#:endfor - -end submodule stdlib_io_npy_save diff --git a/src/stdlib_io_zip.f90 b/src/stdlib_io_zip.f90 new file mode 100644 index 000000000..9d7eac738 --- /dev/null +++ b/src/stdlib_io_zip.f90 @@ -0,0 +1,135 @@ +module stdlib_io_zip + use stdlib_io_minizip + use iso_c_binding, only: c_ptr, c_associated, c_int, c_long, c_char, c_null_char, c_null_ptr + implicit none + private + + public :: unzip, zip_prefix, zip_suffix + + character(*), parameter :: zip_prefix = 'PK'//achar(3)//achar(4) + character(*), parameter :: zip_suffix = 'PK'//achar(5)//achar(6) + integer(kind=c_int), parameter :: read_buffer_size = 1024 + integer(kind=c_long), parameter :: buffer_size = 1024 + + interface unzip + procedure unzip_to_bundle + end interface + + !> Contains extracted raw data from a zip file. + type, public :: t_unzipped_bundle + !> The raw data of the files within the zip file. + type(t_unzipped_file), allocatable :: files(:) + end type + + !> Contains the name of the file and its raw data. + type, public :: t_unzipped_file + !> The name of the file. + character(:), allocatable :: name + !> The raw data of the file. + character(:), allocatable :: data + end type + +contains + + subroutine unzip_to_bundle(filename, bundle, iostat, iomsg) + character(len=*), intent(in) :: filename + type(t_unzipped_bundle), intent(out) :: bundle + integer, intent(out), optional :: iostat + character(len=:), allocatable, intent(out), optional :: iomsg + + type(c_ptr) :: file_handle + type(unz_global_info) :: global_info + type(unz_file_info) :: file_info + integer(kind=c_int) :: stat, bytes_read + character(kind=c_char, len=read_buffer_size) :: read_buffer + character(kind=c_char, len=buffer_size) :: file_name, extra_field, comment + integer(kind=c_long) :: i + + if (present(iostat)) iostat = 0 + + file_handle = c_null_ptr + + file_handle = unz_open(filename//c_null_char) + if (.not. c_associated(file_handle)) then + if (present(iostat)) iostat = 1 + if (present(iomsg)) iomsg = 'Failed to open file '//trim(filename)//'.' + return + end if + + stat = unz_get_global_info(file_handle, global_info) + if (stat /= UNZ_OK) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = 'Failed to get global info for '//trim(filename)//'.' + return + end if + + allocate (bundle%files(global_info%number_of_files)) + + read_files: block + if (size(bundle%files) == 0) exit read_files + + stat = unz_go_to_first_file(file_handle) + if (stat /= UNZ_OK) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = 'Failed to go to first file in '//trim(filename)//'.' + stat = unz_close(file_handle); return + end if + + do i = 1, global_info%number_of_files + stat = unz_open_current_file(file_handle) + if (stat /= UNZ_OK) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = 'Error opening file within '//trim(filename)//'.' + stat = unz_close(file_handle); return + end if + + stat = unz_get_current_file_info(file_handle, file_info, file_name, buffer_size, & + extra_field, buffer_size, comment, buffer_size) + if (stat /= UNZ_OK) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = 'Failed to get current file info in '//trim(filename)//'.' + stat = unz_close(file_handle); return + end if + + bundle%files(i)%name = file_name(1:file_info%size_filename) + bundle%files(i)%data = '' + + do + bytes_read = unz_read_current_file(file_handle, read_buffer, read_buffer_size) + if (bytes_read < 0) then + if (present(iostat)) iostat = bytes_read + if (present(iomsg)) iomsg = 'Error reading file within '//trim(filename)//'.' + stat = unz_close_current_file(file_handle); + stat = unz_close(file_handle); + return + else if (bytes_read == 0) then + stat = unz_close_current_file(file_handle) + if (stat /= UNZ_OK) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = 'Error closing file within '//trim(filename)//'.' + stat = unz_close(file_handle); return + end if + exit + else + bundle%files(i)%data = bundle%files(i)%data//read_buffer(1:bytes_read) + end if + end do + + if (i == global_info%number_of_files) exit + stat = unz_go_to_next_file(file_handle) + if (stat /= UNZ_OK) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = 'Failed to go to next file within '//trim(filename)//'.' + stat = unz_close(file_handle); return + end if + end do + end block read_files + + stat = unz_close(file_handle) + if (stat /= UNZ_OK) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = 'Failed to close file '//trim(filename)//'.' + return + end if + end +end diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 4d83548db..32da608ac 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -4,7 +4,7 @@ endif() macro(ADDTEST name) add_executable(test_${name} test_${name}.f90) - target_link_libraries(test_${name} "${PROJECT_NAME}" "test-drive::test-drive") + target_link_libraries(test_${name} ${PROJECT_NAME} "minizip::minizip" "test-drive::test-drive") add_test(NAME ${name} COMMAND $ ${CMAKE_CURRENT_BINARY_DIR} WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) diff --git a/test/io/CMakeLists.txt b/test/io/CMakeLists.txt index 98794cd88..c2de125b1 100644 --- a/test/io/CMakeLists.txt +++ b/test/io/CMakeLists.txt @@ -14,6 +14,7 @@ set_tests_properties(loadtxt_qp PROPERTIES LABELS quadruple_precision) set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision) ADDTEST(getline) -ADDTEST(npy) +ADDTEST(np) +ADDTEST(zip) ADDTEST(open) ADDTEST(parse_mode) diff --git a/test/io/test_np.f90 b/test/io/test_np.f90 new file mode 100644 index 000000000..157726569 --- /dev/null +++ b/test/io/test_np.f90 @@ -0,0 +1,938 @@ +module test_np + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp + use stdlib_array + use stdlib_strings, only: to_string + use stdlib_io_np, only: load_npy, save_npy, load_npz + use testdrive, only: new_unittest, unittest_type, error_type, check, test_failed + implicit none + private + + public :: collect_np + +contains + + !> Collect all exported unit tests + subroutine collect_np(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("read-rdp-r2", test_read_rdp_rank2), & + new_unittest("read-rdp-r3", test_read_rdp_rank3), & + new_unittest("read-rsp-r1", test_read_rsp_rank1), & + new_unittest("read-rsp-r2", test_read_rsp_rank2), & + new_unittest("write-rdp-r2", test_write_rdp_rank2), & + new_unittest("write-rsp-r2", test_write_rsp_rank2), & + new_unittest("write-i2-r4", test_write_int16_rank4), & + new_unittest("invalid-magic-number", test_invalid_magic_number, should_fail=.true.), & + new_unittest("invalid-magic-string", test_invalid_magic_string, should_fail=.true.), & + new_unittest("invalid-major-version", test_invalid_major_version, should_fail=.true.), & + new_unittest("invalid-minor-version", test_invalid_minor_version, should_fail=.true.), & + new_unittest("invalid-header-len", test_invalid_header_len, should_fail=.true.), & + new_unittest("invalid-nul-byte", test_invalid_nul_byte, should_fail=.true.), & + new_unittest("invalid-key", test_invalid_key, should_fail=.true.), & + new_unittest("invalid-comma", test_invalid_comma, should_fail=.true.), & + new_unittest("invalid-string", test_invalid_string, should_fail=.true.), & + new_unittest("duplicate-descr", test_duplicate_descr, should_fail=.true.), & + new_unittest("missing-descr", test_missing_descr, should_fail=.true.), & + new_unittest("missing-fortran_order", test_missing_fortran_order, should_fail=.true.), & + new_unittest("missing-shape", test_missing_shape, should_fail=.true.), & + new_unittest("iomsg-deallocated", test_iomsg_deallocated), & + new_unittest("npz-nonexistent-file", test_npz_nonexistent_file, should_fail=.true.), & + new_unittest("npz-small-file", test_npz_small_file, should_fail=.true.), & + new_unittest("npz-empty-zip", test_npz_empty_zip, should_fail=.true.), & + new_unittest("npz-not-zip", test_npz_not_zip, should_fail=.true.), & + new_unittest("npz-empty-array", test_npz_empty_array), & + new_unittest("npz-exceeded-rank", test_npz_exceeded_rank, should_fail=.true.), & + new_unittest("npz-single-file-one-dim", test_npz_single_file_one_dim), & + new_unittest("npz-two-files-one-dim", test_npz_two_files) & + ] + end subroutine collect_np + + subroutine test_read_rdp_rank2(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr':' Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(len=*), parameter :: filename = ".test-rdp-r2-rt.npy" + real(dp), allocatable :: input(:, :), output(:, :) + + allocate (input(10, 4)) + call random_number(input) + call save_npy(filename, input, stat) + + call check(error, stat, "Writing of npy file failed") + if (allocated(error)) return + + call load_npy(filename, output, stat) + call delete_file(filename) + + call check(error, stat, "Reading of npy file failed") + if (allocated(error)) return + + call check(error, size(output), size(input)) + if (allocated(error)) return + + call check(error, any(abs(output - input) <= epsilon(1.0_dp)), & + "Precision loss when rereading array") + end subroutine test_write_rdp_rank2 + + subroutine test_write_rsp_rank2(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(len=*), parameter :: filename = ".test-rsp-r2-rt.npy" + real(sp), allocatable :: input(:, :), output(:, :) + + allocate (input(12, 5)) + call random_number(input) + call save_npy(filename, input, stat) + + call check(error, stat, "Writing of npy file failed") + if (allocated(error)) return + + call load_npy(filename, output, stat) + call delete_file(filename) + + call check(error, stat, "Reading of npy file failed") + if (allocated(error)) return + + call check(error, size(output), size(input)) + if (allocated(error)) return + + call check(error, any(abs(output - input) <= epsilon(1.0_dp)), & + "Precision loss when rereading array") + end subroutine test_write_rsp_rank2 + + subroutine test_write_int16_rank4(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: stat, i + character(len=*), parameter :: filename = ".test-i2-r4-rt.npy" + integer(int16), allocatable :: input(:, :, :, :), output(:, :, :, :) + + input = reshape([(i*(i + 1)/2, i=1, 40)], [2, 5, 2, 2]) + call save_npy(filename, input, stat) + + call check(error, stat, "Writing of npy file failed") + if (allocated(error)) return + + call load_npy(filename, output, stat) + call delete_file(filename) + + call check(error, stat, "Reading of npy file failed") + if (allocated(error)) return + + call check(error, size(output), size(input)) + if (allocated(error)) return + + call check(error, all(abs(output - input) == 0), & + "Precision loss when rereading array") + end subroutine test_write_int16_rank4 + + subroutine test_invalid_magic_number(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True,, 'shape': (10, 4, ), 'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True, 'shape': (10, 4, ), } "// & + char(10) + character(len=*), parameter :: header = & + char(int(z"93"))//"NUMPY"//char(1)//char(0)// & + char(len(dict))//char(0)//dict + + integer :: io, stat + character(len=:), allocatable :: msg + character(len=*), parameter :: filename = ".test-missing-descr.npy" + real(dp), allocatable :: array(:, :) + + open (newunit=io, file=filename, form="unformatted", access="stream") + write (io) header + write (io) spread(0.0_dp, 1, 40) + close (io) + + call load_npy(filename, array, stat, msg) + call delete_file(filename) + + call check(error, stat, msg) + end subroutine test_missing_descr + + subroutine test_missing_fortran_order(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True, 'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(len=:), allocatable :: msg + + character(len=*), parameter :: filename = ".test-iomsg-deallocated.npy" + real(sp), allocatable :: input(:, :), output(:, :) + + msg = "This message should be deallocated." + + allocate (input(12, 5)) + call random_number(input) + call save_npy(filename, input, stat, msg) + call delete_file(filename) + + call check(error,.not. allocated(msg), "Message wrongly allocated.") + + end subroutine + + subroutine test_npz_nonexistent_file(error) + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: filename = 'test_nonexistent_file.npz' + type(t_array_wrapper), allocatable :: arrays(:) + integer :: stat + character(len=:), allocatable :: msg + + call load_npz(filename, arrays, stat, msg) + call check(error, stat, msg) + end + + subroutine test_npz_small_file(error) + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: header = 'PK' + integer :: io, stat + character(len=:), allocatable :: msg + character(len=*), parameter :: filename = '.test-small-file.npz' + type(t_array_wrapper), allocatable :: arrays(:) + + open (newunit=io, file=filename, form='unformatted', access='stream') + write (io) header + close (io) + + call load_npz(filename, arrays, stat, msg) + call delete_file(filename) + + call check(error, stat, msg) + end + + subroutine test_npz_empty_zip(error) + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: header = 'PK'//achar(5)//achar(6) + integer :: io, stat + character(len=:), allocatable :: msg + character(len=*), parameter :: filename = '.test-empty-zip.npz' + type(t_array_wrapper), allocatable :: arrays(:) + + open (newunit=io, file=filename, form='unformatted', access='stream') + write (io) header + close (io) + + call load_npz(filename, arrays, stat, msg) + call delete_file(filename) + + call check(error, stat, msg) + end + + subroutine test_npz_not_zip(error) + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: header = 'PK'//achar(3)//achar(5) + integer :: io, stat + character(len=:), allocatable :: msg + character(len=*), parameter :: filename = '.test-not-zip.npz' + type(t_array_wrapper), allocatable :: arrays(:) + + open (newunit=io, file=filename, form='unformatted', access='stream') + write (io) header + close (io) + + call load_npz(filename, arrays, stat, msg) + call delete_file(filename) + + call check(error, stat, msg) + end + + subroutine test_npz_empty_array(error) + type(error_type), allocatable, intent(out) :: error + + character(*), parameter :: binary_data = 'PK'//char(3)//char(4)//'-'//repeat(char(0), 7)//'!'//char(0)//'6H[s'// & + & repeat(char(int(z'ff')), 8)//char(9)//char(0)//char(int(z'14'))//char(0)//'arr_0.npy'//char(1)//char(0)// & + & char(int(z'10'))//char(0)//char(int(z'80'))//repeat(char(0), 7)//char(int(z'80'))//repeat(char(0), 7)// & + & char(int(z'93'))//'NUMPY'//char(1)//char(0)//'v'//char(0)// & + & "{'descr': ' arrays(1)%array) + type is (t_array_rdp_1) + call check(error, allocated(array%values), 'Values not allocated.') + call check(error, size(array%values) == 0, 'Values not empty: '//trim(to_string(size(array%values)))) + class default + call test_failed(error, 'Array not allocated for correct type.') + end select + end + + subroutine test_npz_exceeded_rank(error) + type(error_type), allocatable, intent(out) :: error + + character(*), parameter :: binary_data = 'PK'//char(3)//char(4)//'-'//repeat(char(0), 7)//'!'//char(0)//'8'// & + & char(int(z'17'))//char(int(z'a4'))//'r'//repeat(char(int(z'ff')), 8)//char(9)//char(0)//char(int(z'14'))// & + & char(0)//'arr_0.npy'//char(1)//char(0)//char(int(z'10'))//char(0)//char(int(z'80'))//repeat(char(0), 7)// & + & char(int(z'80'))//repeat(char(0), 7)//char(int(z'93'))//'NUMPY'//char(1)//char(0)//'v'//char(0)// & + & "{'descr': ' arrays(1)%array) + type is (t_array_iint64_1) + call check(error, array%name == 'arr_0.npy', 'Wrong name: '//trim(array%name)) + call check(error, allocated(array%values), 'Values not allocated.') + call check(error, size(array%values) == 3, 'Not 3 entries in values: '//trim(to_string(size(array%values)))) + call check(error, array%values(1) == 2, 'First value is not 2: '//trim(to_string(array%values(1)))) + call check(error, array%values(2) == 4, 'Second value is not 4: '//trim(to_string(array%values(2)))) + call check(error, array%values(3) == 8, 'Third value is not 8: '//trim(to_string(array%values(3)))) + class default + call test_failed(error, 'Array not allocated for correct type.') + end select + end + + subroutine test_npz_two_files(error) + type(error_type), allocatable, intent(out) :: error + + ! arr_0.npy = [[1,2],[3,4]] + ! arr_1.npy = [1.2,3.4] + character(*), parameter :: binary_data = 'PK'//char(3)//char(4)//'-'//repeat(char(0), 7)//'!'//char(0)//char(int(z'a0'))// & + & 'DK['//repeat(char(int(z'ff')), 8)//char(9)//char(0)//char(int(z'14'))//char(0)//'arr_0.npy'//char(1)// & + & char(0)//char(int(z'10'))//char(0)//char(int(z'a0'))//repeat(char(0), 7)//char(int(z'a0'))// & + & repeat(char(0), 7)//char(int(z'93'))//'NUMPY'//char(1)//char(0)//'v'//char(0)// & + & "{'descr': ' arrays(1)%array) + type is (t_array_iint64_2) + call check(error, array%name == 'arr_0.npy', 'Wrong name: '//trim(array%name)) + call check(error, allocated(array%values), 'Values not allocated.') + call check(error, size(array%values) == 4, 'Not 4 entries in values: '//trim(to_string(size(array%values)))) + call check(error, size(array%values, 1) == 2, 'Not 2 entries in dim 1: '//trim(to_string(size(array%values, 2)))) + call check(error, size(array%values, 2) == 2, 'Not 2 entries in dim 2: '//trim(to_string(size(array%values, 2)))) + call check(error, array%values(1, 1) == 1, 'First value in dim 1 not 1: '//trim(to_string(array%values(1, 1)))) + call check(error, array%values(2, 1) == 2, 'Second value in dim 1 not 2: '//trim(to_string(array%values(2, 1)))) + call check(error, array%values(1, 2) == 3, 'First value in dim 2 not 3: '//trim(to_string(array%values(1, 2)))) + call check(error, array%values(2, 2) == 4, 'Second value in dim 2 not 4: '//trim(to_string(array%values(2, 2)))) + class default + call test_failed(error, 'Array not allocated for correct type.') + end select + + select type (array => arrays(2)%array) + type is (t_array_rdp_1) + call check(error, array%name == 'arr_1.npy', 'Wrong name: '//trim(array%name)) + call check(error, allocated(array%values), 'Values not allocated.') + call check(error, size(array%values) == 2, 'Not 2 entries in values: '//trim(to_string(size(array%values)))) + call check(error, array%values(1) == 1.2_dp, 'First value in dim 1 not 1.2: '//trim(to_string(array%values(1)))) + call check(error, array%values(2) == 3.4_dp, 'Second value in dim 1 not 3.4: '//trim(to_string(array%values(2)))) + class default + call test_failed(error, 'Array not allocated for correct type.') + end select + end + + subroutine delete_file(filename) + character(len=*), intent(in) :: filename + + integer :: io + + open (newunit=io, file=filename) + close (io, status="delete") + end subroutine delete_file + +end module test_np + +program tester + use, intrinsic :: iso_fortran_env, only: error_unit + use testdrive, only: run_testsuite, new_testsuite, testsuite_type + use test_np, only: collect_np + implicit none + + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("np", collect_np) & + ] + + do is = 1, size(testsuites) + write (error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write (error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program diff --git a/test/io/test_npy.f90 b/test/io/test_npy.f90 deleted file mode 100644 index c56637030..000000000 --- a/test/io/test_npy.f90 +++ /dev/null @@ -1,680 +0,0 @@ -module test_npy - use stdlib_kinds, only : int8, int16, int32, int64, sp, dp - use stdlib_io_npy, only : save_npy, load_npy - use testdrive, only : new_unittest, unittest_type, error_type, check - implicit none - private - - public :: collect_npy - -contains - - !> Collect all exported unit tests - subroutine collect_npy(testsuite) - !> Collection of tests - type(unittest_type), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - new_unittest("read-rdp-r2", test_read_rdp_rank2), & - new_unittest("read-rdp-r3", test_read_rdp_rank3), & - new_unittest("read-rsp-r1", test_read_rsp_rank1), & - new_unittest("read-rsp-r2", test_read_rsp_rank2), & - new_unittest("write-rdp-r2", test_write_rdp_rank2), & - new_unittest("write-rsp-r2", test_write_rsp_rank2), & - new_unittest("write-i2-r4", test_write_int16_rank4), & - new_unittest("invalid-magic-number", test_invalid_magic_number, should_fail=.true.), & - new_unittest("invalid-magic-string", test_invalid_magic_string, should_fail=.true.), & - new_unittest("invalid-major-version", test_invalid_major_version, should_fail=.true.), & - new_unittest("invalid-minor-version", test_invalid_minor_version, should_fail=.true.), & - new_unittest("invalid-header-len", test_invalid_header_len, should_fail=.true.), & - new_unittest("invalid-nul-byte", test_invalid_nul_byte, should_fail=.true.), & - new_unittest("invalid-key", test_invalid_key, should_fail=.true.), & - new_unittest("invalid-comma", test_invalid_comma, should_fail=.true.), & - new_unittest("invalid-string", test_invalid_string, should_fail=.true.), & - new_unittest("duplicate-descr", test_duplicate_descr, should_fail=.true.), & - new_unittest("missing-descr", test_missing_descr, should_fail=.true.), & - new_unittest("missing-fortran_order", test_missing_fortran_order, should_fail=.true.), & - new_unittest("missing-shape", test_missing_shape, should_fail=.true.), & - new_unittest("iomsg-deallocated", test_iomsg_deallocated) & - ] - end subroutine collect_npy - - subroutine test_read_rdp_rank2(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr':' Error handling - type(error_type), allocatable, intent(out) :: error - - integer :: stat - character(len=*), parameter :: filename = ".test-rdp-r2-rt.npy" - real(dp), allocatable :: input(:, :), output(:, :) - - allocate(input(10, 4)) - call random_number(input) - call save_npy(filename, input, stat) - - call check(error, stat, "Writing of npy file failed") - if (allocated(error)) return - - call load_npy(filename, output, stat) - call delete_file(filename) - - call check(error, stat, "Reading of npy file failed") - if (allocated(error)) return - - call check(error, size(output), size(input)) - if (allocated(error)) return - - call check(error, any(abs(output - input) <= epsilon(1.0_dp)), & - "Precision loss when rereading array") - end subroutine test_write_rdp_rank2 - - subroutine test_write_rsp_rank2(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer :: stat - character(len=*), parameter :: filename = ".test-rsp-r2-rt.npy" - real(sp), allocatable :: input(:, :), output(:, :) - - allocate(input(12, 5)) - call random_number(input) - call save_npy(filename, input, stat) - - call check(error, stat, "Writing of npy file failed") - if (allocated(error)) return - - call load_npy(filename, output, stat) - call delete_file(filename) - - call check(error, stat, "Reading of npy file failed") - if (allocated(error)) return - - call check(error, size(output), size(input)) - if (allocated(error)) return - - call check(error, any(abs(output - input) <= epsilon(1.0_dp)), & - "Precision loss when rereading array") - end subroutine test_write_rsp_rank2 - - subroutine test_write_int16_rank4(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer :: stat, i - character(len=*), parameter :: filename = ".test-i2-r4-rt.npy" - integer(int16), allocatable :: input(:, :, :, :), output(:, :, :, :) - - input = reshape([(i*(i+1)/2, i = 1, 40)], [2, 5, 2, 2]) - call save_npy(filename, input, stat) - - call check(error, stat, "Writing of npy file failed") - if (allocated(error)) return - - call load_npy(filename, output, stat) - call delete_file(filename) - - call check(error, stat, "Reading of npy file failed") - if (allocated(error)) return - - call check(error, size(output), size(input)) - if (allocated(error)) return - - call check(error, all(abs(output - input) == 0), & - "Precision loss when rereading array") - end subroutine test_write_int16_rank4 - - subroutine test_invalid_magic_number(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True,, 'shape': (10, 4, ), 'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True, 'shape': (10, 4, ), } " // & - char(10) - character(len=*), parameter :: header = & - char(int(z"93")) // "NUMPY" // char(1) // char(0) // & - char(len(dict)) // char(0) // dict - - integer :: io, stat - character(len=:), allocatable :: msg - character(len=*), parameter :: filename = ".test-missing-descr.npy" - real(dp), allocatable :: array(:, :) - - open(newunit=io, file=filename, form="unformatted", access="stream") - write(io) header - write(io) spread(0.0_dp, 1, 40) - close(io) - - call load_npy(filename, array, stat, msg) - call delete_file(filename) - - call check(error, stat, msg) - end subroutine test_missing_descr - - subroutine test_missing_fortran_order(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True, 'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - integer :: stat - character(len=:), allocatable :: msg - - character(len=*), parameter :: filename = ".test-iomsg-deallocated.npy" - real(sp), allocatable :: input(:, :), output(:, :) - - msg = "This message should be deallocated." - - allocate(input(12, 5)) - call random_number(input) - call save_npy(filename, input, stat, msg) - call delete_file(filename) - - call check(error,.not. allocated(msg), "Message wrongly allocated.") - - end subroutine - - subroutine delete_file(filename) - character(len=*), intent(in) :: filename - - integer :: io - - open(newunit=io, file=filename) - close(io, status="delete") - end subroutine delete_file - -end module test_npy - - -program tester - use, intrinsic :: iso_fortran_env, only : error_unit - use testdrive, only : run_testsuite, new_testsuite, testsuite_type - use test_npy, only : collect_npy - implicit none - integer :: stat, is - type(testsuite_type), allocatable :: testsuites(:) - character(len=*), parameter :: fmt = '("#", *(1x, a))' - - stat = 0 - - testsuites = [ & - new_testsuite("npy", collect_npy) & - ] - - do is = 1, size(testsuites) - write(error_unit, fmt) "Testing:", testsuites(is)%name - call run_testsuite(testsuites(is)%collect, error_unit, stat) - end do - - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" - error stop - end if -end program diff --git a/test/io/test_zip.f90 b/test/io/test_zip.f90 new file mode 100644 index 000000000..0e44b622f --- /dev/null +++ b/test/io/test_zip.f90 @@ -0,0 +1,193 @@ +module test_zip + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp + use stdlib_io_zip, only: t_unzipped_bundle, unzip + use testdrive, only: new_unittest, unittest_type, error_type, check + implicit none + private + + public :: collect_np + +contains + + subroutine collect_np(testsuite) + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest('unexistent-file', test_unexistent_file, should_fail=.true.), & + ! new_unittest('empty-zip', test_empty_zip), & + new_unittest('empty-array', test_empty_array), & + new_unittest('single-file', test_single_file), & + new_unittest('two-files', test_two_files) & + ] + end + + subroutine test_unexistent_file(error) + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: filename = 'unexistent-file.zip' + type(t_unzipped_bundle) :: bundle + integer :: stat + character(len=:), allocatable :: msg + + call unzip(filename, bundle, stat, msg) + call check(error, stat, msg) + end + + subroutine test_empty_zip(error) + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: filename = 'test_empty_zip.zip' + type(t_unzipped_bundle) :: bundle + integer :: io, stat + character(len=:), allocatable :: msg + + character(*), parameter:: binary_data = 'PK'//char(5)//char(6)//repeat(char(0), 18) + + open (newunit=io, file=filename, form='unformatted', access='stream') + write (io) binary_data + close (io) + + call unzip(filename, bundle, stat, msg) + call delete_file(filename) + + call check(error, stat, msg) + call check(error, size(bundle%files) == 0, 'Files should be empty') + end + + subroutine test_empty_array(error) + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: filename = 'test_empty_array.zip' + type(t_unzipped_bundle) :: bundle + integer :: io, stat + character(len=:), allocatable :: msg + + character(*), parameter :: binary_data = 'PK'//char(3)//char(4)//'-'//repeat(char(0), 7)//'!'//char(0)//'6H[s'// & + & repeat(char(int(z'ff')), 8)//char(9)//char(0)//char(int(z'14'))//char(0)//'arr_0.npy'//char(1)//char(0)// & + & char(int(z'10'))//char(0)//char(int(z'80'))//repeat(char(0), 7)//char(int(z'80'))//repeat(char(0), 7)// & + & char(int(z'93'))//'NUMPY'//char(1)//char(0)//'v'//char(0)// & + & "{'descr': ' 0) then + write (error_unit, '(i0, 1x, a)') stat, 'test(s) failed!' + error stop + end if +end program diff --git a/test/string/test_string_derivedtype_io.f90 b/test/string/test_string_derivedtype_io.f90 index c99272dac..ccc5cdcaa 100644 --- a/test/string/test_string_derivedtype_io.f90 +++ b/test/string/test_string_derivedtype_io.f90 @@ -1,4 +1,4 @@ -! SPDX-Identifer: MIT +! SPDX-Identifier: MIT module test_string_derivedtype_io use testdrive, only : new_unittest, unittest_type, error_type, check use stdlib_string_type, only : string_type, assignment(=), len, & diff --git a/test/string/test_string_intrinsic.f90 b/test/string/test_string_intrinsic.f90 index c84fbbd48..11fa40c13 100644 --- a/test/string/test_string_intrinsic.f90 +++ b/test/string/test_string_intrinsic.f90 @@ -1,4 +1,4 @@ -! SPDX-Identifer: MIT +! SPDX-Identifier: MIT module test_string_intrinsic use testdrive, only : new_unittest, unittest_type, error_type, check use stdlib_string_type diff --git a/test/string/test_string_operator.f90 b/test/string/test_string_operator.f90 index 0252f3f45..d2ed2f390 100644 --- a/test/string/test_string_operator.f90 +++ b/test/string/test_string_operator.f90 @@ -1,4 +1,4 @@ -! SPDX-Identifer: MIT +! SPDX-Identifier: MIT module test_string_operator use testdrive, only : new_unittest, unittest_type, error_type, check use stdlib_string_type, only : string_type, assignment(=), len, &