diff --git a/Makefile b/Makefile index 4a0ab9d..6149b86 100644 --- a/Makefile +++ b/Makefile @@ -140,7 +140,7 @@ TARGET = $(DISTDIR)/libdmpack.a SHARED = $(DISTDIR)/libdmpack.so # Debug and release options. -DEBUG = -g -O0 -Wall -fcheck=all -fmax-errors=1 +DEBUG = -g -O0 -Wall -Wpedantic -fcheck=all -fmax-errors=1 RELEASE = -mtune=native -O2 # Common build options. @@ -289,6 +289,7 @@ SRC = $(SRCDIR)/dm_ansi.f90 \ $(SRCDIR)/dm_util.f90 \ $(SRCDIR)/dm_uuid.f90 \ $(SRCDIR)/dm_version.f90 \ + $(SRCDIR)/dm_z.f90 \ $(SRCDIR)/dm_zlib.f90 \ $(SRCDIR)/dm_zstd.f90 \ $(SRCDIR)/dmpack.f90 @@ -375,6 +376,7 @@ OBJ = dm_ansi.o \ dm_util.o \ dm_uuid.o \ dm_version.o \ + dm_z.o \ dm_zlib.o \ dm_zstd.o \ dmpack.o @@ -549,6 +551,7 @@ $(OBJ): $(SRC) $(FC) $(FFLAGS) $(LDFLAGS) -c src/dm_db.f90 $(FC) $(FFLAGS) $(LDFLAGS) -c src/dm_zlib.f90 $(FC) $(FFLAGS) $(LDFLAGS) -c src/dm_zstd.f90 + $(FC) $(FFLAGS) $(LDFLAGS) -c src/dm_z.f90 $(FC) $(FFLAGS) $(LDFLAGS) -c src/dm_person.f90 $(FC) $(FFLAGS) $(LDFLAGS) -c src/dm_mail.f90 $(FC) $(FFLAGS) $(LDFLAGS) -c src/dm_http.f90 diff --git a/src/dm_ascii.f90 b/src/dm_ascii.f90 index ccee2b5..92b6ab4 100644 --- a/src/dm_ascii.f90 +++ b/src/dm_ascii.f90 @@ -42,7 +42,7 @@ module dm_ascii public :: dm_ascii_escape public :: dm_ascii_is_alpha - public :: dm_ascii_is_alpha_num + public :: dm_ascii_is_alpha_numeric public :: dm_ascii_is_blank public :: dm_ascii_is_control public :: dm_ascii_is_digit @@ -97,96 +97,96 @@ pure function dm_ascii_escape(str) result(res) end do end function dm_ascii_escape - pure elemental logical function dm_ascii_is_alpha(a) result(is_alpha) + pure elemental logical function dm_ascii_is_alpha(a) result(is) !! Returns whether character is alpha letter. character, intent(in) :: a !! Character to check. - is_alpha = (a >= 'A' .and. a <= 'Z') .or. (a >= 'a' .and. a <= 'z') + is = ((a >= 'A' .and. a <= 'Z') .or. (a >= 'a' .and. a <= 'z')) end function dm_ascii_is_alpha - pure elemental logical function dm_ascii_is_alpha_num(a) result(is_alpha_num) + pure elemental logical function dm_ascii_is_alpha_numeric(a) result(is) !! Returns whether character is alpha-numeric. character, intent(in) :: a !! Character to check. - is_alpha_num = (a >= '0' .and. a <= '9') .or. & - (a >= 'A' .and. a <= 'Z') .or. & - (a >= 'a' .and. a <= 'z') - end function dm_ascii_is_alpha_num + is = ((a >= '0' .and. a <= '9') .or. & + (a >= 'A' .and. a <= 'Z') .or. & + (a >= 'a' .and. a <= 'z')) + end function dm_ascii_is_alpha_numeric - pure elemental logical function dm_ascii_is_blank(a) result(is_blank) + pure elemental logical function dm_ascii_is_blank(a) result(is) !! Returns whether character is space or tabular. character, intent(in) :: a !! Character to check. - integer :: i + integer :: ia - i = iachar(a) - is_blank = (a == ' ') .or. (i == int(z'09')) + ia = iachar(a) + is = ((a == ' ') .or. (ia == int(z'09'))) end function dm_ascii_is_blank - pure elemental logical function dm_ascii_is_control(a) result(is_control) + pure elemental logical function dm_ascii_is_control(a) result(is) !! Returns whether character is control character. character, intent(in) :: a !! Character to check. - integer :: i + integer :: ia - i = iachar(a) - is_control = (i < int(z'20')) .or. (i == int(z'7F')) + ia = iachar(a) + is = ((ia < int(z'20')) .or. (ia == int(z'7F'))) end function dm_ascii_is_control - pure elemental logical function dm_ascii_is_digit(a) result(is_digit) + pure elemental logical function dm_ascii_is_digit(a) result(is) !! Returns whether character is digit. character, intent(in) :: a !! Character to check. - is_digit = (a >= '0') .and. (a <= '9') + is = ((a >= '0') .and. (a <= '9')) end function dm_ascii_is_digit - pure elemental logical function dm_ascii_is_hex_digit(a) result(is_hex) + pure elemental logical function dm_ascii_is_hex_digit(a) result(is) !! Returns whether character is hex digit. character, intent(in) :: a !! Character to check. - is_hex = (a >= '0' .and. a <= '9') .or. & - (a >= 'A' .and. a <= 'F') .or. & - (a >= 'a' .and. a <= 'f') + is = ((a >= '0' .and. a <= '9') .or. & + (a >= 'A' .and. a <= 'F') .or. & + (a >= 'a' .and. a <= 'f')) end function dm_ascii_is_hex_digit - pure elemental logical function dm_ascii_is_lower(a) result(is_lower) + pure elemental logical function dm_ascii_is_lower(a) result(is) !! Returns whether character is lower-case. character, intent(in) :: a !! Character to check. - integer :: i + integer :: ia - i = iachar(a) - is_lower = (i >= iachar('a')) .and. (i <= iachar('z')) + ia = iachar(a) + is = ((ia >= iachar('a')) .and. (ia <= iachar('z'))) end function dm_ascii_is_lower - pure elemental logical function dm_ascii_is_octal_digit(a) result(is_octal) + pure elemental logical function dm_ascii_is_octal_digit(a) result(is) !! Returns whether character is an octal digit. character, intent(in) :: a !! Character to check. - is_octal = (a >= '0') .and. (a <= '7') + is = ((a >= '0') .and. (a <= '7')) end function dm_ascii_is_octal_digit - pure elemental logical function dm_ascii_is_printable(a) result(is_printable) + pure elemental logical function dm_ascii_is_printable(a) result(is) !! Returns whether character is printable. character, intent(in) :: a !! Character to check. - integer :: i + integer :: ia - i = iachar(a) - is_printable = (i >= iachar(' ')) .and. (i <= int(z'7E')) + ia = iachar(a) + is = ((ia >= iachar(' ')) .and. (ia <= int(z'7E'))) end function dm_ascii_is_printable - pure elemental logical function dm_ascii_is_upper(a) result(is_upper) + pure elemental logical function dm_ascii_is_upper(a) result(is) !! Returns whether character is upper-case. character, intent(in) :: a !! Character to check. - is_upper = (a >= 'A') .and. (a <= 'Z') + is = ((a >= 'A') .and. (a <= 'Z')) end function dm_ascii_is_upper - pure elemental logical function dm_ascii_is_white_space(a) result(is_white) + pure elemental logical function dm_ascii_is_white_space(a) result(is) !! Returns whether character is white space (either `SPACE`, `TAB`, !! `LF`, `VT`, `FF`, or `CR`). character, intent(in) :: a !! Character to check. - integer :: i + integer :: ia - i = iachar(a) - is_white = (a == ' ') .or. (i >= int(z'09') .and. i <= int(z'0D')) + ia = iachar(a) + is = ((a == ' ') .or. (ia >= int(z'09') .and. ia <= int(z'0D'))) end function dm_ascii_is_white_space pure function dm_ascii_unescape(str) result(res) diff --git a/src/dm_cgi.f90 b/src/dm_cgi.f90 index 198347d..840eb9e 100644 --- a/src/dm_cgi.f90 +++ b/src/dm_cgi.f90 @@ -97,7 +97,7 @@ module dm_cgi ! PUBLIC PROCEDURES. ! ****************************************************************** logical function dm_cgi_auth(env) result(auth) - !! Returns `.true.` is CGI environment variable `AUTH` is set. + !! Returns `.true.` if CGI environment variable `AUTH` is set. type(cgi_env_type), intent(inout) :: env !! CGI environment type. auth = (len_trim(env%auth_type) > 0) @@ -188,13 +188,13 @@ function dm_cgi_has(param, key) result(has) character(len=*), intent(in) :: key !! Parameter key. logical :: has - integer :: i + integer :: loc integer(kind=i8) :: hash - has = .false. + has = .false. hash = dm_hash_fnv1a(trim(key)) - i = findloc(param%hashes, hash, dim=1) - if (i == 0) return + loc = findloc(param%hashes, hash, dim=1) + if (loc == 0) return has = .true. end function dm_cgi_has @@ -204,29 +204,29 @@ function dm_cgi_has_value(param, key) result(has) character(len=*), intent(in) :: key !! Parameter key. logical :: has - integer :: i + integer :: loc integer(kind=i8) :: hash - has = .false. + has = .false. hash = dm_hash_fnv1a(trim(key)) - i = findloc(param%hashes, hash, dim=1) - if (i == 0) return - if (len_trim(param%values(i)) == 0) return + loc = findloc(param%hashes, hash, dim=1) + if (loc == 0) return + if (len_trim(param%values(loc)) == 0) return has = .true. end function dm_cgi_has_value - function dm_cgi_key(param, i) result(str) - !! Returns key at index `i` in keys array of `param`. + function dm_cgi_key(param, loc) result(str) + !! Returns key at index `loc` in keys array of `param`. type(cgi_param_type), intent(inout) :: param !! CGI parameter type. - integer, intent(in) :: i !! Array index. + integer, intent(in) :: loc !! Array index. character(len=:), allocatable :: str !! Key or empty. - if ((param%cursor == 0) .or. (i < 1) .or. (i > param%cursor)) then + if ((param%cursor == 0) .or. (loc < 1) .or. (loc > param%cursor)) then str = '' return end if - str = trim(param%keys(i)) + str = trim(param%keys(loc)) end function dm_cgi_key function dm_cgi_size(param) result(sz) @@ -238,18 +238,18 @@ function dm_cgi_size(param) result(sz) sz = param%cursor end function dm_cgi_size - function dm_cgi_value(param, i) result(str) + function dm_cgi_value(param, loc) result(str) !! Returns value at index `i` in values array of `param`. type(cgi_param_type), intent(inout) :: param !! CGI parameter type. - integer, intent(in) :: i !! Array index. + integer, intent(in) :: loc !! Array index. character(len=:), allocatable :: str !! Value or empty. - if ((param%cursor == 0) .or. (i < 1) .or. (i > param%cursor)) then + if ((param%cursor == 0) .or. (loc < 1) .or. (loc > param%cursor)) then str = '' return end if - str = trim(param%values(i)) + str = trim(param%values(loc)) end function dm_cgi_value subroutine dm_cgi_env(env) @@ -384,14 +384,14 @@ end subroutine dm_cgi_query integer function cgi_get_int32(param, key, value, default, required) result(rc) !! Returns (last) value associated with key in `param` as 32-bit integer. !! The return code is set to `E_EMPTY` if the key does not exist and - !! `required` has not been not passed or is `.true.` + !! `required` has not been passed or is `.true.` type(cgi_param_type), intent(inout) :: param !! CGI parameter type. character(len=*), intent(in) :: key !! Parameter key. integer(kind=i4), intent(out) :: value !! Parameter value. integer(kind=i4), intent(in), optional :: default !! Default value. logical, intent(in), optional :: required !! Required flag. - integer :: i + integer :: loc rc = E_EMPTY if (present(required)) then @@ -401,23 +401,23 @@ integer function cgi_get_int32(param, key, value, default, required) result(rc) value = 0 if (present(default)) value = default - i = cgi_param_loc(param, key) - if (i == 0) return - if (len_trim(param%values(i)) == 0) return - call dm_string_to(param%values(i), value, rc) + loc = cgi_param_loc(param, key) + if (loc == 0) return + if (len_trim(param%values(loc)) == 0) return + call dm_string_to(param%values(loc), value, rc) end function cgi_get_int32 integer function cgi_get_int64(param, key, value, default, required) result(rc) !! Returns (last) value associated with key in `param` as 64-bit !! integer. The return code is set to `E_EMPTY` if the key does not - !! exist and `required` has not been not passed or is `.true.` + !! exist and `required` has not been passed or is `.true.` type(cgi_param_type), intent(inout) :: param !! CGI parameters. character(len=*), intent(in) :: key !! Parameter key. integer(kind=i8), intent(out) :: value !! Parameter value. integer(kind=i8), intent(in), optional :: default !! Default value. logical, intent(in), optional :: required !! Required flag. - integer :: i + integer :: loc rc = E_EMPTY if (present(required)) then @@ -427,23 +427,23 @@ integer function cgi_get_int64(param, key, value, default, required) result(rc) value = 0 if (present(default)) value = default - i = cgi_param_loc(param, key) - if (i == 0) return - if (len_trim(param%values(i)) == 0) return - call dm_string_to(param%values(i), value, rc) + loc = cgi_param_loc(param, key) + if (loc == 0) return + if (len_trim(param%values(loc)) == 0) return + call dm_string_to(param%values(loc), value, rc) end function cgi_get_int64 integer function cgi_get_logical(param, key, value, default, required) result(rc) !! Returns (last) value associated with key in `param` as logical. The !! return code is set to `E_EMPTY` if the key does not exist and - !! `required` has not been not passed or is `.true.` + !! `required` has not been passed or is `.true.` type(cgi_param_type), intent(inout) :: param !! CGI parameter type. character(len=*), intent(in) :: key !! Parameter key. logical, intent(out) :: value !! Parameter value. logical, intent(in), optional :: default !! Default value. logical, intent(in), optional :: required !! Required flag. - integer :: i, j, stat + integer :: i, loc, stat rc = E_EMPTY if (present(required)) then @@ -453,27 +453,27 @@ integer function cgi_get_logical(param, key, value, default, required) result(rc value = .false. if (present(default)) value = default - i = cgi_param_loc(param, key) - if (i == 0) return + loc = cgi_param_loc(param, key) + if (loc == 0) return rc = E_TYPE - call dm_string_to(param%values(i), j, stat) + call dm_string_to(param%values(loc), i, stat) if (stat /= E_NONE) return - value = .not. (j == 0) + value = .not. (i == 0) rc = E_NONE end function cgi_get_logical integer function cgi_get_real32(param, key, value, default, required) result(rc) !! Returns (last) value associated with key in `param` as 32-bit real. !! The return code is set to `E_EMPTY` if the key does not exist and - !! `required` has not been not passed or is `.true.` + !! `required` has not been passed or is `.true.` type(cgi_param_type), intent(inout) :: param !! CGI parameter type. character(len=*), intent(in) :: key !! Parameter key. real(kind=r4), intent(out) :: value !! Parameter value. real(kind=r4), intent(in), optional :: default !! Default value. logical, intent(in), optional :: required !! Required flag. - integer :: i + integer :: loc rc = E_EMPTY if (present(required)) then @@ -483,23 +483,23 @@ integer function cgi_get_real32(param, key, value, default, required) result(rc) value = 0.0 if (present(default)) value = default - i = cgi_param_loc(param, key) - if (i == 0) return - if (len_trim(param%values(i)) == 0) return - call dm_string_to(param%values(i), value, rc) + loc = cgi_param_loc(param, key) + if (loc == 0) return + if (len_trim(param%values(loc)) == 0) return + call dm_string_to(param%values(loc), value, rc) end function cgi_get_real32 integer function cgi_get_real64(param, key, value, default, required) result(rc) !! Returns (last) value associated with key in `param` as 64-bit real. !! The return code is set to `E_EMPTY` if the key does not exist and - !! `required` has not been not passed or is `.true.`. + !! `required` has not been passed or is `.true.`. type(cgi_param_type), intent(inout) :: param !! CGI parameter type. character(len=*), intent(in) :: key !! Parameter key. real(kind=r8), intent(out) :: value !! Parameter value. real(kind=r8), intent(in), optional :: default !! Default value. logical, intent(in), optional :: required !! Required flag. - integer :: i + integer :: loc rc = E_EMPTY if (present(required)) then @@ -509,23 +509,23 @@ integer function cgi_get_real64(param, key, value, default, required) result(rc) value = 0.0 if (present(default)) value = default - i = cgi_param_loc(param, key) - if (i == 0) return - if (len_trim(param%values(i)) == 0) return - call dm_string_to(param%values(i), value, rc) + loc = cgi_param_loc(param, key) + if (loc == 0) return + if (len_trim(param%values(loc)) == 0) return + call dm_string_to(param%values(loc), value, rc) end function cgi_get_real64 integer function cgi_get_string(param, key, value, default, required) result(rc) !! Returns (last) value associated with key in `param`. The return code !! is set to `E_EMPTY` if the key does not exist and `required` has not - !! been not passed or is `.true.` + !! been passed or is `.true.` type(cgi_param_type), intent(inout) :: param !! CGI parameter type. character(len=*), intent(in) :: key !! Parameter key. character(len=*), intent(inout) :: value !! Parameter value. character(len=*), intent(in), optional :: default !! Default value. logical, intent(in), optional :: required !! Required flag. - integer :: i + integer :: loc rc = E_EMPTY if (present(required)) then @@ -534,10 +534,10 @@ integer function cgi_get_string(param, key, value, default, required) result(rc) get_block: block value = '' - i = cgi_param_loc(param, key) - if (i == 0) exit get_block - if (len_trim(param%values(i)) == 0) exit get_block - value = trim(param%values(i)) + loc = cgi_param_loc(param, key) + if (loc == 0) exit get_block + if (len_trim(param%values(loc)) == 0) exit get_block + value = trim(param%values(loc)) rc = E_NONE return end block get_block @@ -545,7 +545,7 @@ integer function cgi_get_string(param, key, value, default, required) result(rc) if (present(default)) value = default end function cgi_get_string - integer function cgi_param_loc(param, key) result(i) + integer function cgi_param_loc(param, key) result(loc) !! Returns location of key in parameter keys array, or 0 if not found. type(cgi_param_type), intent(inout) :: param !! CGI parameter type. character(len=*), intent(in) :: key !! Parameter key. @@ -553,6 +553,6 @@ integer function cgi_param_loc(param, key) result(i) integer(kind=i8) :: hash hash = dm_hash_fnv1a(trim(key)) - i = findloc(param%hashes, hash, dim=1, back=.true.) + loc = findloc(param%hashes, hash, dim=1, back=.true.) end function cgi_param_loc end module dm_cgi diff --git a/src/dm_hash_table.f90 b/src/dm_hash_table.f90 index 4b0cb50..1339ccc 100644 --- a/src/dm_hash_table.f90 +++ b/src/dm_hash_table.f90 @@ -42,11 +42,11 @@ module dm_hash_table ! ****************************************************************** ! PUBLIC PROCEDURES. ! ****************************************************************** - logical function dm_hash_table_allocated(hash_table) result(is_alloc) + logical function dm_hash_table_allocated(hash_table) result(is) !! Returns `.true.` if hash table arrays have been allocated. type(hash_table_type), intent(inout) :: hash_table !! Hash table type. - is_alloc = (allocated(hash_table%hashes) .and. allocated(hash_table%values)) + is = (allocated(hash_table%hashes) .and. allocated(hash_table%values)) end function dm_hash_table_allocated integer function dm_hash_table_create(hash_table, max_entries) result(rc) @@ -76,17 +76,17 @@ integer function dm_hash_table_set(hash_table, key, value) result(rc) character(len=*), intent(in) :: key !! Hash table key. class(*), target, intent(inout) :: value !! Associated value. - integer :: i + integer :: loc integer(kind=i8) :: hash rc = E_LIMIT hash = hash_table_hash(key) - i = findloc(hash_table%hashes, hash, dim=1) + loc = findloc(hash_table%hashes, hash, dim=1) - if (i == 0) i = hash_table%cursor + 1 - if (i > size(hash_table%hashes)) return - if (i > 0) hash_table%cursor = i + if (loc == 0) loc = hash_table%cursor + 1 + if (loc > size(hash_table%hashes)) return + if (loc > 0) hash_table%cursor = loc hash_table%hashes(hash_table%cursor) = hash hash_table%values(hash_table%cursor)%ptr => value @@ -129,22 +129,22 @@ end subroutine dm_hash_table_size ! ****************************************************************** ! PRIVATE PROCEDURES. ! ****************************************************************** - integer function hash_table_get_index(hash_table, i, value) result(rc) + integer function hash_table_get_index(hash_table, loc, value) result(rc) !! Returns pointer to element in hash table by index `i`. On error, !! `value` will point to null. type(hash_table_type), intent(inout) :: hash_table !! Hash table type. - integer, intent(in) :: i !! Hash value index. + integer, intent(in) :: loc !! Hash value index. class(*), pointer, intent(out) :: value !! Associated value. rc = E_BOUNDS value => null() - if (i < 1 .or. i > size(hash_table%values)) return + if (loc < 1 .or. loc > size(hash_table%values)) return rc = E_INVALID - if (.not. associated(hash_table%values(i)%ptr)) return + if (.not. associated(hash_table%values(loc)%ptr)) return - value => hash_table%values(i)%ptr + value => hash_table%values(loc)%ptr rc = E_NONE end function hash_table_get_index @@ -157,20 +157,20 @@ integer function hash_table_get_key(hash_table, key, value) result(rc) character(len=*), intent(in) :: key !! Hash table key. class(*), pointer, intent(out) :: value !! Associated value. - integer :: i + integer :: loc integer(kind=i8) :: hash rc = E_EMPTY value => null() hash = hash_table_hash(key) - i = findloc(hash_table%hashes, hash, dim=1) - if (i == 0) return + loc = findloc(hash_table%hashes, hash, dim=1) + if (loc == 0) return rc = E_INVALID - if (.not. associated(hash_table%values(i)%ptr)) return + if (.not. associated(hash_table%values(loc)%ptr)) return - value => hash_table%values(i)%ptr + value => hash_table%values(loc)%ptr rc = E_NONE end function hash_table_get_key diff --git a/src/dm_z.f90 b/src/dm_z.f90 new file mode 100644 index 0000000..2171278 --- /dev/null +++ b/src/dm_z.f90 @@ -0,0 +1,134 @@ +! Author: Philipp Engel +! Licence: ISC +module dm_z + !! Utility module for type-based compression and decompression (zlib, zstd). + use :: dm_error + use :: dm_kind + use :: dm_nml + use :: dm_zlib + use :: dm_zstd + implicit none (type, external) + private + + ! Encoding types. + integer, parameter, public :: Z_TYPE_INVALID = -1 !! Invalid or unknown encoding. + integer, parameter, public :: Z_TYPE_NONE = 0 !! No compression. + integer, parameter, public :: Z_TYPE_ZLIB = 1 !! Deflate compression. + integer, parameter, public :: Z_TYPE_ZSTD = 2 !! Zstandard compression. + integer, parameter, public :: Z_TYPE_LAST = 2 !! Never use this. + + integer, parameter, public :: Z_TYPE_NAME_LEN = 4 !! Max. encoding type name length. + + character(len=*), parameter, public :: Z_TYPE_NAMES(0:Z_TYPE_LAST) = [ & + character(len=4) :: 'none', 'zlib', 'zstd' & + ] !! Encoding type names. + + interface dm_z_uncompress + module procedure :: z_uncompress + module procedure :: z_uncompress_beat + end interface + + ! Public procedures. + public :: dm_z_type_from_name + public :: dm_z_type_to_name + public :: dm_z_uncompress + public :: dm_z_valid + + ! Private procedures. + private :: z_uncompress + private :: z_uncompress_beat +contains + ! ****************************************************************** + ! PUBLIC PROCEDURES. + ! ****************************************************************** + pure elemental integer function dm_z_type_from_name(name) result(type) + !! Returns encoding type from name. The function returns + !! `Z_TYPE_INVALID` if the name is not a valid type name, and + !! `Z_TYPE_NONE` if the string is empty or `none`. + use :: dm_string, only: dm_lower + + character(len=*), intent(in) :: name !! Compression type name. + character(len=Z_TYPE_NAME_LEN) :: name_ + + ! Normalise type name. + name_ = dm_lower(name) + + select case (name_) + case (' ', Z_TYPE_NAMES(Z_TYPE_NONE)) + type = Z_TYPE_NONE + case (Z_TYPE_NAMES(Z_TYPE_ZLIB)) + type = Z_TYPE_ZLIB + case (Z_TYPE_NAMES(Z_TYPE_ZSTD)) + type = Z_TYPE_ZSTD + case default + type = Z_TYPE_INVALID + end select + end function dm_z_type_from_name + + pure elemental character(len=Z_TYPE_NAME_LEN) function dm_z_type_to_name(type) result(name) + !! Returns encoding type name from given type, for example, + !! `Z_TYPE_NONE`, `Z_TYPE_ZLIB`, or `Z_TYPE_ZSTD`. If an invalid type + !! is passed, the function returns `none`. + integer, intent(in) :: type !! Compression type. + + if (.not. dm_z_valid(type)) then + name = Z_TYPE_NAMES(Z_TYPE_NONE) + return + end if + + name = Z_TYPE_NAMES(type) + end function dm_z_type_to_name + + pure elemental logical function dm_z_valid(type) result(valid) + !! Returns `.true.` if the given compression type `type` is valid. The + !! type `Z_TYPE_NONE` is a valid type, and `Z_TYPE_INVALID` is invalid. + integer, intent(in) :: type !! Compression type. + + valid = (type >= Z_TYPE_NONE .and. type <= Z_TYPE_LAST) + end function dm_z_valid + + ! ****************************************************************** + ! PRIVATE PROCEDURES. + ! ****************************************************************** + integer function z_uncompress(input, output, type, input_len, output_len) result(rc) + character(len=*), intent(inout) :: input !! Compressed data. + character(len=*), intent(inout) :: output !! Uncompressed data. + integer, intent(in) :: type !! Input encoding type (`Z_TYPE_*`). + integer(kind=i8), intent(in), optional :: input_len !! Actual input length. + integer(kind=i8), intent(out), optional :: output_len !! Actual output length. + + rc = E_INVALID + if (.not. dm_z_valid(type)) return + + rc = E_NONE + select case (type) + case (Z_TYPE_NONE) + if (present(input_len)) then + output = input(:input_len) + else + output = input + end if + + case (Z_TYPE_ZLIB) + rc = dm_zlib_uncompress(input, output, input_len=input_len, output_len=output_len) + + case (Z_TYPE_ZSTD) + rc = dm_zstd_uncompress(input, output, input_len=input_len, output_len=output_len) + end select + end function z_uncompress + + integer function z_uncompress_beat(input, beat, type, input_len) result(rc) + use :: dm_beat + + character(len=*), intent(inout) :: input !! Compressed and Namelist-serialised beat. + type(beat_type), intent(out) :: beat !! Beat type to uncompress and deserialise. + integer, intent(in) :: type !! Input encoding type (`Z_TYPE_*`). + integer(kind=i8), intent(in), optional :: input_len !! Actual input length. + + character(len=NML_BEAT_LEN) :: output + + rc = z_uncompress(input, output, type, input_len=input_len) + if (dm_is_error(rc)) return + rc = dm_nml_to(output, beat) + end function z_uncompress_beat +end module dm_z diff --git a/src/dm_zlib.f90 b/src/dm_zlib.f90 index 611700d..ef6a3fd 100644 --- a/src/dm_zlib.f90 +++ b/src/dm_zlib.f90 @@ -11,7 +11,7 @@ module dm_zlib public :: dm_zlib_compress public :: dm_zlib_uncompress contains - integer function dm_zlib_compress(input, output, output_len) result(rc) + integer function dm_zlib_compress(input, output, input_len, output_len) result(rc) !! Compresses input string using the zlib utility function. !! !! The function returns the following error codes: @@ -22,44 +22,61 @@ integer function dm_zlib_compress(input, output, output_len) result(rc) !! character(len=*), intent(inout) :: input !! Input bytes. character(len=:), allocatable, intent(out) :: output !! Output bytes. + integer(kind=i8), intent(in), optional :: input_len !! Actual input length. integer(kind=i8), intent(out), optional :: output_len !! Actual output length. integer :: stat - integer(kind=z_ulong) :: sz + integer(kind=z_ulong) :: in_len, out_len + + if (present(input_len)) then + in_len = int(input_len, kind=z_ulong) + else + in_len = len(input, kind=z_ulong) + end if if (present(output_len)) output_len = 0 - sz = compress_bound(len(input, kind=z_ulong)) + + out_len = compress_bound(in_len) rc = E_ALLOC - allocate (character(len=sz) :: output, stat=stat) + allocate (character(len=out_len) :: output, stat=stat) if (stat /= 0) return rc = E_EMPTY - if (sz == 0) return + if (out_len == 0) return rc = E_ZLIB - stat = compress(output, sz, input, len(input, kind=z_ulong)) - if (present(output_len)) output_len = int(sz, kind=i8) - if (stat /= Z_OK) return + stat = compress(output, out_len, input, in_len) + if (present(output_len)) output_len = int(out_len, kind=i8) + if (stat /= Z_OK) return rc = E_NONE end function dm_zlib_compress - integer function dm_zlib_uncompress(input, output, output_len) result(rc) + integer function dm_zlib_uncompress(input, output, input_len, output_len) result(rc) !! Uncompresses input string using the zlib utility function. The output !! buffer must be large enough to hold the uncompressed result. Returns !! `E_ZLIB` if the decompression failed. character(len=*), intent(inout) :: input !! Input bytes. character(len=*), intent(inout) :: output !! Output bytes. + integer(kind=i8), intent(in), optional :: input_len !! Actual input length. integer(kind=i8), intent(out), optional :: output_len !! Actual output length. integer :: stat - integer(kind=z_ulong) :: sz + integer(kind=z_ulong) :: in_len, out_len + + if (present(input_len)) then + in_len = int(input_len, kind=z_ulong) + else + in_len = len(input, kind=z_ulong) + end if + + out_len = len(output, kind=z_ulong) rc = E_ZLIB - sz = len(output, kind=z_ulong) - stat = uncompress(output, sz, input, len(input, kind=z_ulong)) - if (present(output_len)) output_len = int(sz, kind=i8) + stat = uncompress(output, out_len, input, in_len) + + if (present(output_len)) output_len = int(out_len, kind=i8) if (stat /= Z_OK) return rc = E_NONE end function dm_zlib_uncompress diff --git a/src/dm_zstd.f90 b/src/dm_zstd.f90 index 136f545..25fe3fe 100644 --- a/src/dm_zstd.f90 +++ b/src/dm_zstd.f90 @@ -87,6 +87,9 @@ integer function zstd_compress_multi(context, input, output, level, output_len) !! Zstandard context `context` has to be destroy with !! `dm_zstd_destroy()` once finished. !! + !! The string `output` may be larger than the actual length. The + !! argument `output_len` contains the actual length. + !! !! The function returns the following error codes: !! !! * `E_ALLOC` if the allocation of the output string failed. @@ -99,11 +102,11 @@ integer function zstd_compress_multi(context, input, output, level, output_len) integer, intent(in), optional :: level !! Compression level. integer(kind=i8), intent(out), optional :: output_len !! Actual output length. - integer :: level_, stat - integer(kind=c_size_t) :: in_len, out_len - integer(kind=c_size_t) :: n + integer :: level_ + integer(kind=c_size_t) :: in_len, out_len, stat + integer(kind=i8) :: output_len_ - n = 0 + output_len_ = 0 zstd_block: block rc = E_EMPTY @@ -128,18 +131,23 @@ integer function zstd_compress_multi(context, input, output, level, output_len) level_ = dm_zstd_level_default() end if - n = zstd_compress_c_ctx(context%c, output, out_len, input, in_len, level_) - if (zstd_is_error(n)) exit zstd_block + stat = zstd_compress_c_ctx(context%c, output, out_len, input, in_len, level_) + if (zstd_is_error(stat)) exit zstd_block + output_len_ = stat + rc = E_NONE end block zstd_block - if (present(output_len)) output_len = n + if (present(output_len)) output_len = output_len_ end function zstd_compress_multi integer function zstd_compress_single(input, output, level, output_len) result(rc) !! Compresses input string using the zstd simple function. If no !! compression level is passed, the Zstandard default is used. !! + !! The string `output` may be larger than the actual length. The + !! argument `output_len` contains the actual length. + !! !! The function returns the following error codes: !! !! * `E_ALLOC` if the allocation of the output string failed. @@ -151,11 +159,11 @@ integer function zstd_compress_single(input, output, level, output_len) result(r integer, intent(in), optional :: level !! Compression level. integer(kind=i8), intent(out), optional :: output_len !! Actual output length. - integer :: level_, stat - integer(kind=c_size_t) :: in_len, out_len - integer(kind=c_size_t) :: n + integer :: level_ + integer(kind=c_size_t) :: in_len, out_len, stat + integer(kind=i8) :: output_len_ - n = 0 + output_len_ = 0 zstd_block: block rc = E_EMPTY @@ -175,13 +183,14 @@ integer function zstd_compress_single(input, output, level, output_len) result(r end if rc = E_ZSTD - n = zstd_compress(output, out_len, input, in_len, level_) - if (zstd_is_error(n)) exit zstd_block + stat = zstd_compress(output, out_len, input, in_len, level_) + if (zstd_is_error(stat)) exit zstd_block + output_len_ = stat rc = E_NONE end block zstd_block - if (present(output_len)) output_len = n + if (present(output_len)) output_len = output_len_ end function zstd_compress_single integer function zstd_uncompress_multi(context, input, output, input_len, output_len) result(rc) @@ -196,9 +205,10 @@ integer function zstd_uncompress_multi(context, input, output, input_len, output integer(kind=i8), intent(in), optional :: input_len !! Actual input length. integer(kind=i8), intent(out), optional :: output_len !! Actual output length. - integer(kind=c_size_t) :: input_len_, n + integer(kind=c_size_t) :: input_len_, stat + integer(kind=i8) :: output_len_ - n = 0 + output_len_ = 0 zstd_block: block rc = E_ZSTD @@ -213,12 +223,14 @@ integer function zstd_uncompress_multi(context, input, output, input_len, output input_len_ = len(input, kind=c_size_t) end if - n = zstd_decompress_d_ctx(context%d, output, len(output, kind=c_size_t), input, input_len_) - if (zstd_is_error(n)) exit zstd_block + stat = zstd_decompress_d_ctx(context%d, output, len(output, kind=c_size_t), input, input_len_) + if (zstd_is_error(stat)) exit zstd_block + output_len_ = stat + rc = E_NONE end block zstd_block - if (present(output_len)) output_len = n + if (present(output_len)) output_len = output_len_ end function zstd_uncompress_multi integer function zstd_uncompress_single(input, output, input_len, output_len) result(rc) @@ -230,9 +242,11 @@ integer function zstd_uncompress_single(input, output, input_len, output_len) re integer(kind=i8), intent(in), optional :: input_len !! Actual input length. integer(kind=i8), intent(out), optional :: output_len !! Actual output length. - integer(kind=c_size_t) :: input_len_, n + integer(kind=c_size_t) :: input_len_, stat + integer(kind=i8) :: output_len_ rc = E_ZSTD + output_len_ = 0 if (present(input_len)) then input_len_ = int(input_len, kind=c_size_t) @@ -240,9 +254,13 @@ integer function zstd_uncompress_single(input, output, input_len, output_len) re input_len_ = len(input, kind=c_size_t) end if - n = zstd_decompress(output, len(output, kind=c_size_t), input, input_len_) - if (.not. zstd_is_error(n)) rc = E_NONE + stat = zstd_decompress(output, len(output, kind=c_size_t), input, input_len_) + + if (.not. zstd_is_error(stat)) then + rc = E_NONE + output_len_ = stat + end if - if (present(output_len)) output_len = n + if (present(output_len)) output_len = output_len_ end function zstd_uncompress_single end module dm_zstd diff --git a/src/dmpack.f90 b/src/dmpack.f90 index d6e6022..fc430a5 100644 --- a/src/dmpack.f90 +++ b/src/dmpack.f90 @@ -109,6 +109,7 @@ module dmpack use :: dm_util use :: dm_uuid use :: dm_version + use :: dm_z use :: dm_zlib use :: dm_zstd implicit none (type, external)