| 1 |
module fgof_cache |
| 2 |
use iso_fortran_env, only : int64 |
| 3 |
use fgof_cache_posix, only : & |
| 4 |
current_time_seconds_posix, & |
| 5 |
directory_exists_posix, & |
| 6 |
ensure_directory_posix, & |
| 7 |
path_probe_posix, & |
| 8 |
prune_stale_posix, & |
| 9 |
remove_file_posix, & |
| 10 |
stat_path_posix |
| 11 |
use fgof_temp, only : atomic_write |
| 12 |
use fgof_temp_types, only : write_result |
| 13 |
use fgof_cache_types, only : & |
| 14 |
FGOF_CACHE_ERR_INTERNAL, & |
| 15 |
FGOF_CACHE_ERR_INVALID_OPTIONS, & |
| 16 |
FGOF_CACHE_ERR_IO, & |
| 17 |
FGOF_CACHE_ERR_NOT_FOUND, & |
| 18 |
FGOF_CACHE_OK, & |
| 19 |
cache_entry, & |
| 20 |
cache_prune_result, & |
| 21 |
cache_root, & |
| 22 |
cache_text_result, & |
| 23 |
cache_options |
| 24 |
implicit none |
| 25 |
private |
| 26 |
|
| 27 |
public :: & |
| 28 |
FGOF_CACHE_ERR_INTERNAL, & |
| 29 |
FGOF_CACHE_ERR_INVALID_OPTIONS, & |
| 30 |
FGOF_CACHE_ERR_IO, & |
| 31 |
FGOF_CACHE_ERR_NOT_FOUND, & |
| 32 |
FGOF_CACHE_OK, & |
| 33 |
cache_backend_name, & |
| 34 |
cache_entry, & |
| 35 |
cache_entry_is_stale, & |
| 36 |
cache_key_token, & |
| 37 |
cache_path_for_key, & |
| 38 |
cache_prune_result, & |
| 39 |
cache_relative_path_for_key, & |
| 40 |
cache_root, & |
| 41 |
cache_text_result, & |
| 42 |
cache_error_name, & |
| 43 |
cache_options, & |
| 44 |
clear_cache_root, & |
| 45 |
clear_cache_entry, & |
| 46 |
clear_cache_prune_result, & |
| 47 |
clear_cache_text_result, & |
| 48 |
clear_cache_options, & |
| 49 |
ensure_cache_root, & |
| 50 |
prune_stale_cache, & |
| 51 |
read_cache_text, & |
| 52 |
remove_cache_entry, & |
| 53 |
write_cache_text, & |
| 54 |
resolve_cache_entry |
| 55 |
|
| 56 |
contains |
| 57 |
|
| 58 |
function clear_cache_options() result(options) |
| 59 |
type(cache_options) :: options |
| 60 |
|
| 61 |
options%create_root = .true. |
| 62 |
end function clear_cache_options |
| 63 |
|
| 64 |
function clear_cache_root() result(root) |
| 65 |
type(cache_root) :: root |
| 66 |
|
| 67 |
root%ready = .false. |
| 68 |
root%error_code = FGOF_CACHE_OK |
| 69 |
root%path = "" |
| 70 |
root%error_message = "" |
| 71 |
end function clear_cache_root |
| 72 |
|
| 73 |
function clear_cache_entry() result(entry) |
| 74 |
type(cache_entry) :: entry |
| 75 |
|
| 76 |
entry%present = .false. |
| 77 |
entry%error_code = FGOF_CACHE_OK |
| 78 |
call clear_entry_metadata(entry) |
| 79 |
entry%key = "" |
| 80 |
entry%root_path = "" |
| 81 |
entry%relative_path = "" |
| 82 |
entry%path = "" |
| 83 |
entry%error_message = "" |
| 84 |
end function clear_cache_entry |
| 85 |
|
| 86 |
function clear_cache_text_result() result(result_value) |
| 87 |
type(cache_text_result) :: result_value |
| 88 |
|
| 89 |
result_value%found = .false. |
| 90 |
result_value%error_code = FGOF_CACHE_OK |
| 91 |
result_value%entry = clear_cache_entry() |
| 92 |
result_value%text = "" |
| 93 |
result_value%error_message = "" |
| 94 |
end function clear_cache_text_result |
| 95 |
|
| 96 |
function clear_cache_prune_result() result(result_value) |
| 97 |
type(cache_prune_result) :: result_value |
| 98 |
|
| 99 |
result_value%completed = .false. |
| 100 |
result_value%error_code = FGOF_CACHE_OK |
| 101 |
result_value%scanned_count = 0_int64 |
| 102 |
result_value%removed_count = 0_int64 |
| 103 |
result_value%root_path = "" |
| 104 |
result_value%error_message = "" |
| 105 |
end function clear_cache_prune_result |
| 106 |
|
| 107 |
function ensure_cache_root(options) result(root) |
| 108 |
type(cache_options), intent(in), optional :: options |
| 109 |
type(cache_root) :: root |
| 110 |
type(cache_options) :: local_options |
| 111 |
character(len=:), allocatable :: root_path |
| 112 |
integer :: sys_errno |
| 113 |
logical :: success |
| 114 |
|
| 115 |
local_options = merged_options(options) |
| 116 |
root = clear_cache_root() |
| 117 |
|
| 118 |
if (.not. validate_options(local_options, root)) return |
| 119 |
|
| 120 |
if (.not. resolved_root_path(local_options, root_path)) then |
| 121 |
call set_root_error(root, FGOF_CACHE_ERR_INVALID_OPTIONS, & |
| 122 |
"unable to resolve cache root: set root_dir, XDG_CACHE_HOME, or HOME") |
| 123 |
return |
| 124 |
end if |
| 125 |
|
| 126 |
root%path = root_path |
| 127 |
|
| 128 |
if (local_options%create_root) then |
| 129 |
success = ensure_directory_posix(root_path, sys_errno) |
| 130 |
if (.not. success) then |
| 131 |
call set_root_error(root, FGOF_CACHE_ERR_IO, errno_message("cache root creation failed", sys_errno)) |
| 132 |
return |
| 133 |
end if |
| 134 |
else |
| 135 |
if (.not. directory_exists_posix(root_path)) then |
| 136 |
call set_root_error(root, FGOF_CACHE_ERR_NOT_FOUND, "cache root does not exist") |
| 137 |
return |
| 138 |
end if |
| 139 |
end if |
| 140 |
|
| 141 |
if (.not. directory_exists_posix(root_path)) then |
| 142 |
call set_root_error(root, FGOF_CACHE_ERR_IO, "cache root exists but is not a directory") |
| 143 |
return |
| 144 |
end if |
| 145 |
|
| 146 |
root%ready = .true. |
| 147 |
root%error_code = FGOF_CACHE_OK |
| 148 |
root%error_message = "" |
| 149 |
end function ensure_cache_root |
| 150 |
|
| 151 |
function cache_key_token(key) result(token) |
| 152 |
character(len=*), intent(in) :: key |
| 153 |
character(len=:), allocatable :: token |
| 154 |
character(len=16), parameter :: hex_digits = "0123456789abcdef" |
| 155 |
integer :: byte_value |
| 156 |
integer :: i |
| 157 |
|
| 158 |
if (len(key) == 0) then |
| 159 |
token = "" |
| 160 |
return |
| 161 |
end if |
| 162 |
|
| 163 |
allocate(character(len=2 * len(key)) :: token) |
| 164 |
do i = 1, len(key) |
| 165 |
byte_value = iachar(key(i:i)) |
| 166 |
token(2 * i - 1:2 * i - 1) = hex_digits(byte_value / 16 + 1:byte_value / 16 + 1) |
| 167 |
token(2 * i:2 * i) = hex_digits(mod(byte_value, 16) + 1:mod(byte_value, 16) + 1) |
| 168 |
end do |
| 169 |
end function cache_key_token |
| 170 |
|
| 171 |
function cache_relative_path_for_key(key) result(path) |
| 172 |
character(len=*), intent(in) :: key |
| 173 |
character(len=:), allocatable :: path |
| 174 |
character(len=:), allocatable :: token |
| 175 |
|
| 176 |
token = cache_key_token(key) |
| 177 |
if (len(token) == 0) then |
| 178 |
path = "" |
| 179 |
return |
| 180 |
end if |
| 181 |
|
| 182 |
path = join_path(join_path(shard_segment(token, 1), shard_segment(token, 3)), token) |
| 183 |
end function cache_relative_path_for_key |
| 184 |
|
| 185 |
function cache_path_for_key(root_path, key) result(path) |
| 186 |
character(len=*), intent(in) :: root_path |
| 187 |
character(len=*), intent(in) :: key |
| 188 |
character(len=:), allocatable :: path |
| 189 |
character(len=:), allocatable :: relative_path |
| 190 |
|
| 191 |
relative_path = cache_relative_path_for_key(key) |
| 192 |
if (len(relative_path) == 0) then |
| 193 |
path = "" |
| 194 |
return |
| 195 |
end if |
| 196 |
|
| 197 |
path = join_path(root_path, relative_path) |
| 198 |
end function cache_path_for_key |
| 199 |
|
| 200 |
function resolve_cache_entry(key, options) result(entry) |
| 201 |
character(len=*), intent(in) :: key |
| 202 |
type(cache_options), intent(in), optional :: options |
| 203 |
type(cache_entry) :: entry |
| 204 |
|
| 205 |
if (.not. prepare_entry(key, options, create_root_requested(options, .true.), entry)) return |
| 206 |
if (.not. inspect_entry(entry, .true.)) return |
| 207 |
end function resolve_cache_entry |
| 208 |
|
| 209 |
function write_cache_text(key, text, options) result(entry) |
| 210 |
character(len=*), intent(in) :: key |
| 211 |
character(len=*), intent(in) :: text |
| 212 |
type(cache_options), intent(in), optional :: options |
| 213 |
type(cache_entry) :: entry |
| 214 |
character(len=:), allocatable :: parent_path |
| 215 |
integer :: sys_errno |
| 216 |
logical :: success |
| 217 |
type(write_result) :: write_outcome |
| 218 |
|
| 219 |
if (.not. prepare_entry(key, options, .true., entry)) return |
| 220 |
if (.not. inspect_entry(entry, .false.)) return |
| 221 |
|
| 222 |
parent_path = parent_directory(entry%path) |
| 223 |
success = ensure_directory_posix(parent_path, sys_errno) |
| 224 |
if (.not. success) then |
| 225 |
call set_entry_error(entry, FGOF_CACHE_ERR_IO, errno_message("cache entry directory creation failed", sys_errno)) |
| 226 |
return |
| 227 |
end if |
| 228 |
|
| 229 |
write_outcome = atomic_write(entry%path, text) |
| 230 |
if (.not. write_outcome%completed) then |
| 231 |
call set_entry_error(entry, FGOF_CACHE_ERR_IO, write_outcome%error_message) |
| 232 |
return |
| 233 |
end if |
| 234 |
|
| 235 |
entry%present = .true. |
| 236 |
call refresh_entry_metadata(entry) |
| 237 |
entry%error_code = FGOF_CACHE_OK |
| 238 |
entry%error_message = "" |
| 239 |
end function write_cache_text |
| 240 |
|
| 241 |
function read_cache_text(key, options) result(result_value) |
| 242 |
character(len=*), intent(in) :: key |
| 243 |
type(cache_options), intent(in), optional :: options |
| 244 |
type(cache_text_result) :: result_value |
| 245 |
type(cache_entry) :: entry |
| 246 |
|
| 247 |
result_value = clear_cache_text_result() |
| 248 |
entry = resolve_read_entry(key, options) |
| 249 |
result_value%entry = entry |
| 250 |
|
| 251 |
if (entry%error_code /= FGOF_CACHE_OK) then |
| 252 |
result_value%error_code = entry%error_code |
| 253 |
result_value%error_message = entry%error_message |
| 254 |
return |
| 255 |
end if |
| 256 |
|
| 257 |
if (.not. entry%present) then |
| 258 |
result_value%error_code = FGOF_CACHE_ERR_NOT_FOUND |
| 259 |
result_value%error_message = "cache entry not found" |
| 260 |
return |
| 261 |
end if |
| 262 |
|
| 263 |
call read_text_file(entry%path, result_value%text, result_value%error_code, result_value%error_message) |
| 264 |
if (result_value%error_code /= FGOF_CACHE_OK) return |
| 265 |
|
| 266 |
result_value%found = .true. |
| 267 |
result_value%error_message = "" |
| 268 |
end function read_cache_text |
| 269 |
|
| 270 |
function remove_cache_entry(key, options) result(entry) |
| 271 |
character(len=*), intent(in) :: key |
| 272 |
type(cache_options), intent(in), optional :: options |
| 273 |
type(cache_entry) :: entry |
| 274 |
integer :: sys_errno |
| 275 |
logical :: success |
| 276 |
|
| 277 |
if (.not. prepare_entry(key, options, .false., entry)) return |
| 278 |
if (.not. inspect_entry(entry, .false.)) return |
| 279 |
|
| 280 |
if (.not. entry%present) then |
| 281 |
call set_entry_error(entry, FGOF_CACHE_ERR_NOT_FOUND, "cache entry not found") |
| 282 |
return |
| 283 |
end if |
| 284 |
|
| 285 |
success = remove_file_posix(entry%path, sys_errno) |
| 286 |
if (.not. success) then |
| 287 |
call set_entry_error(entry, FGOF_CACHE_ERR_IO, errno_message("cache entry removal failed", sys_errno)) |
| 288 |
return |
| 289 |
end if |
| 290 |
|
| 291 |
entry%present = .false. |
| 292 |
call clear_entry_metadata(entry) |
| 293 |
entry%error_code = FGOF_CACHE_OK |
| 294 |
entry%error_message = "" |
| 295 |
end function remove_cache_entry |
| 296 |
|
| 297 |
logical function cache_entry_is_stale(entry, max_age_seconds, reference_time_seconds) result(stale) |
| 298 |
type(cache_entry), intent(in) :: entry |
| 299 |
integer(int64), intent(in) :: max_age_seconds |
| 300 |
integer(int64), intent(in), optional :: reference_time_seconds |
| 301 |
integer(int64) :: now_seconds |
| 302 |
|
| 303 |
stale = .false. |
| 304 |
|
| 305 |
if (.not. entry%present) return |
| 306 |
if (.not. entry%metadata_available) return |
| 307 |
if (max_age_seconds < 0_int64) return |
| 308 |
|
| 309 |
now_seconds = effective_reference_time(reference_time_seconds) |
| 310 |
if (now_seconds < 0_int64) return |
| 311 |
|
| 312 |
stale = stale_from_times(entry%modified_time_seconds, max_age_seconds, now_seconds) |
| 313 |
end function cache_entry_is_stale |
| 314 |
|
| 315 |
function prune_stale_cache(max_age_seconds, options, reference_time_seconds) result(result_value) |
| 316 |
integer(int64), intent(in) :: max_age_seconds |
| 317 |
type(cache_options), intent(in), optional :: options |
| 318 |
integer(int64), intent(in), optional :: reference_time_seconds |
| 319 |
type(cache_prune_result) :: result_value |
| 320 |
type(cache_options) :: local_options |
| 321 |
type(cache_root) :: root |
| 322 |
integer(int64) :: cutoff_seconds |
| 323 |
integer(int64) :: now_seconds |
| 324 |
integer :: sys_errno |
| 325 |
logical :: success |
| 326 |
|
| 327 |
result_value = clear_cache_prune_result() |
| 328 |
|
| 329 |
if (max_age_seconds < 0_int64) then |
| 330 |
call set_prune_error(result_value, FGOF_CACHE_ERR_INVALID_OPTIONS, "max_age_seconds must not be negative") |
| 331 |
return |
| 332 |
end if |
| 333 |
|
| 334 |
local_options = merged_options(options) |
| 335 |
if (.not. validate_prune_options(local_options, result_value)) return |
| 336 |
local_options%create_root = .false. |
| 337 |
root = ensure_cache_root(local_options) |
| 338 |
result_value%root_path = root%path |
| 339 |
|
| 340 |
if (root%error_code == FGOF_CACHE_ERR_NOT_FOUND) then |
| 341 |
result_value%completed = .true. |
| 342 |
return |
| 343 |
end if |
| 344 |
if (.not. root%ready) then |
| 345 |
call set_prune_error(result_value, root%error_code, root%error_message) |
| 346 |
return |
| 347 |
end if |
| 348 |
|
| 349 |
now_seconds = effective_reference_time(reference_time_seconds) |
| 350 |
if (now_seconds < 0_int64) then |
| 351 |
call set_prune_error(result_value, FGOF_CACHE_ERR_INTERNAL, "unable to resolve current time") |
| 352 |
return |
| 353 |
end if |
| 354 |
|
| 355 |
cutoff_seconds = stale_cutoff(max_age_seconds, now_seconds) |
| 356 |
success = prune_stale_posix(root%path, cutoff_seconds, result_value%scanned_count, & |
| 357 |
result_value%removed_count, sys_errno) |
| 358 |
if (.not. success) then |
| 359 |
call set_prune_error(result_value, FGOF_CACHE_ERR_IO, errno_message("cache prune failed", sys_errno)) |
| 360 |
return |
| 361 |
end if |
| 362 |
|
| 363 |
result_value%completed = .true. |
| 364 |
result_value%error_code = FGOF_CACHE_OK |
| 365 |
result_value%error_message = "" |
| 366 |
end function prune_stale_cache |
| 367 |
|
| 368 |
function cache_backend_name() result(name) |
| 369 |
character(len=:), allocatable :: name |
| 370 |
|
| 371 |
name = "posix" |
| 372 |
end function cache_backend_name |
| 373 |
|
| 374 |
function cache_error_name(code) result(name) |
| 375 |
integer, intent(in) :: code |
| 376 |
character(len=:), allocatable :: name |
| 377 |
|
| 378 |
select case (code) |
| 379 |
case (FGOF_CACHE_OK) |
| 380 |
name = "ok" |
| 381 |
case (FGOF_CACHE_ERR_INVALID_OPTIONS) |
| 382 |
name = "invalid-options" |
| 383 |
case (FGOF_CACHE_ERR_NOT_FOUND) |
| 384 |
name = "not-found" |
| 385 |
case (FGOF_CACHE_ERR_IO) |
| 386 |
name = "io" |
| 387 |
case (FGOF_CACHE_ERR_INTERNAL) |
| 388 |
name = "internal" |
| 389 |
case default |
| 390 |
name = "unknown" |
| 391 |
end select |
| 392 |
end function cache_error_name |
| 393 |
|
| 394 |
function resolve_read_entry(key, options) result(entry) |
| 395 |
character(len=*), intent(in) :: key |
| 396 |
type(cache_options), intent(in), optional :: options |
| 397 |
type(cache_entry) :: entry |
| 398 |
type(cache_options) :: local_options |
| 399 |
|
| 400 |
local_options = merged_options(options) |
| 401 |
local_options%create_root = .false. |
| 402 |
entry = resolve_cache_entry(key, local_options) |
| 403 |
end function resolve_read_entry |
| 404 |
|
| 405 |
logical function prepare_entry(key, options, create_root, entry) result(success) |
| 406 |
character(len=*), intent(in) :: key |
| 407 |
type(cache_options), intent(in), optional :: options |
| 408 |
logical, intent(in) :: create_root |
| 409 |
type(cache_entry), intent(out) :: entry |
| 410 |
type(cache_options) :: local_options |
| 411 |
type(cache_root) :: root |
| 412 |
|
| 413 |
entry = clear_cache_entry() |
| 414 |
entry%key = key |
| 415 |
|
| 416 |
if (len(key) == 0) then |
| 417 |
call set_entry_error(entry, FGOF_CACHE_ERR_INVALID_OPTIONS, "cache key must not be empty") |
| 418 |
success = .false. |
| 419 |
return |
| 420 |
end if |
| 421 |
|
| 422 |
local_options = merged_options(options) |
| 423 |
local_options%create_root = create_root |
| 424 |
root = ensure_cache_root(local_options) |
| 425 |
if (.not. root%ready) then |
| 426 |
entry%root_path = root%path |
| 427 |
call set_entry_error(entry, root%error_code, root%error_message) |
| 428 |
success = .false. |
| 429 |
return |
| 430 |
end if |
| 431 |
|
| 432 |
entry%root_path = root%path |
| 433 |
entry%relative_path = cache_relative_path_for_key(key) |
| 434 |
entry%path = cache_path_for_key(root%path, key) |
| 435 |
entry%error_code = FGOF_CACHE_OK |
| 436 |
entry%error_message = "" |
| 437 |
success = .true. |
| 438 |
end function prepare_entry |
| 439 |
|
| 440 |
function merged_options(options) result(local_options) |
| 441 |
type(cache_options), intent(in), optional :: options |
| 442 |
type(cache_options) :: local_options |
| 443 |
|
| 444 |
local_options = clear_cache_options() |
| 445 |
if (present(options)) local_options = options |
| 446 |
end function merged_options |
| 447 |
|
| 448 |
logical function create_root_requested(options, default_value) result(create_root) |
| 449 |
type(cache_options), intent(in), optional :: options |
| 450 |
logical, intent(in) :: default_value |
| 451 |
|
| 452 |
create_root = default_value |
| 453 |
if (present(options)) create_root = options%create_root |
| 454 |
end function create_root_requested |
| 455 |
|
| 456 |
logical function validate_options(options, root) result(valid) |
| 457 |
type(cache_options), intent(in) :: options |
| 458 |
type(cache_root), intent(inout) :: root |
| 459 |
|
| 460 |
valid = .false. |
| 461 |
|
| 462 |
if (allocated(options%root_dir)) then |
| 463 |
if (len(options%root_dir) == 0) then |
| 464 |
call set_root_error(root, FGOF_CACHE_ERR_INVALID_OPTIONS, "root_dir must not be empty") |
| 465 |
return |
| 466 |
end if |
| 467 |
end if |
| 468 |
|
| 469 |
if (allocated(options%namespace)) then |
| 470 |
if (len(options%namespace) == 0) then |
| 471 |
call set_root_error(root, FGOF_CACHE_ERR_INVALID_OPTIONS, "namespace must not be empty") |
| 472 |
return |
| 473 |
end if |
| 474 |
if (index(options%namespace, "/") > 0) then |
| 475 |
call set_root_error(root, FGOF_CACHE_ERR_INVALID_OPTIONS, "namespace must not contain '/'") |
| 476 |
return |
| 477 |
end if |
| 478 |
if (options%namespace == "." .or. options%namespace == "..") then |
| 479 |
call set_root_error(root, FGOF_CACHE_ERR_INVALID_OPTIONS, "namespace must not be '.' or '..'") |
| 480 |
return |
| 481 |
end if |
| 482 |
end if |
| 483 |
|
| 484 |
valid = .true. |
| 485 |
end function validate_options |
| 486 |
|
| 487 |
logical function validate_prune_options(options, result_value) result(valid) |
| 488 |
type(cache_options), intent(in) :: options |
| 489 |
type(cache_prune_result), intent(inout) :: result_value |
| 490 |
|
| 491 |
valid = .false. |
| 492 |
|
| 493 |
if (allocated(options%root_dir) .and. len(options%root_dir) > 0 .and. .not. allocated(options%namespace)) then |
| 494 |
call set_prune_error(result_value, FGOF_CACHE_ERR_INVALID_OPTIONS, & |
| 495 |
"namespace is required when pruning an explicit root_dir") |
| 496 |
return |
| 497 |
end if |
| 498 |
|
| 499 |
valid = .true. |
| 500 |
end function validate_prune_options |
| 501 |
|
| 502 |
logical function resolved_root_path(options, root_path) result(valid) |
| 503 |
type(cache_options), intent(in) :: options |
| 504 |
character(len=:), allocatable, intent(out) :: root_path |
| 505 |
character(len=:), allocatable :: base_path |
| 506 |
|
| 507 |
valid = .false. |
| 508 |
root_path = "" |
| 509 |
|
| 510 |
if (allocated(options%root_dir)) then |
| 511 |
base_path = options%root_dir |
| 512 |
else |
| 513 |
base_path = default_cache_base() |
| 514 |
if (.not. allocated(base_path)) return |
| 515 |
end if |
| 516 |
|
| 517 |
if (allocated(options%namespace)) then |
| 518 |
root_path = join_path(base_path, options%namespace) |
| 519 |
else if (allocated(options%root_dir)) then |
| 520 |
root_path = base_path |
| 521 |
else |
| 522 |
root_path = join_path(base_path, "fgof-cache") |
| 523 |
end if |
| 524 |
|
| 525 |
valid = .true. |
| 526 |
end function resolved_root_path |
| 527 |
|
| 528 |
function default_cache_base() result(base_path) |
| 529 |
character(len=:), allocatable :: base_path |
| 530 |
character(len=:), allocatable :: xdg_cache_home |
| 531 |
character(len=:), allocatable :: home |
| 532 |
|
| 533 |
xdg_cache_home = getenv_text("XDG_CACHE_HOME") |
| 534 |
if (allocated(xdg_cache_home)) then |
| 535 |
base_path = xdg_cache_home |
| 536 |
return |
| 537 |
end if |
| 538 |
|
| 539 |
home = getenv_text("HOME") |
| 540 |
if (allocated(home)) then |
| 541 |
base_path = join_path(home, ".cache") |
| 542 |
end if |
| 543 |
end function default_cache_base |
| 544 |
|
| 545 |
function getenv_text(name) result(value) |
| 546 |
character(len=*), intent(in) :: name |
| 547 |
character(len=:), allocatable :: value |
| 548 |
integer :: length |
| 549 |
integer :: status |
| 550 |
|
| 551 |
call get_environment_variable(name, length=length, status=status) |
| 552 |
if (status /= 0 .or. length <= 0) return |
| 553 |
|
| 554 |
allocate(character(len=length) :: value) |
| 555 |
call get_environment_variable(name, value, status=status) |
| 556 |
if (status /= 0) then |
| 557 |
deallocate(value) |
| 558 |
end if |
| 559 |
end function getenv_text |
| 560 |
|
| 561 |
function join_path(left, right) result(path) |
| 562 |
character(len=*), intent(in) :: left |
| 563 |
character(len=*), intent(in) :: right |
| 564 |
character(len=:), allocatable :: path |
| 565 |
|
| 566 |
if (len(left) == 0) then |
| 567 |
path = right |
| 568 |
else if (len(right) == 0) then |
| 569 |
path = left |
| 570 |
else if (left(len(left):len(left)) == "/") then |
| 571 |
path = left // right |
| 572 |
else |
| 573 |
path = left // "/" // right |
| 574 |
end if |
| 575 |
end function join_path |
| 576 |
|
| 577 |
function shard_segment(token, start_index) result(segment) |
| 578 |
character(len=*), intent(in) :: token |
| 579 |
integer, intent(in) :: start_index |
| 580 |
character(len=:), allocatable :: segment |
| 581 |
|
| 582 |
if (start_index > len(token)) then |
| 583 |
segment = "00" |
| 584 |
else if (start_index == len(token)) then |
| 585 |
segment = token(start_index:start_index) // "0" |
| 586 |
else |
| 587 |
segment = token(start_index:start_index + 1) |
| 588 |
end if |
| 589 |
end function shard_segment |
| 590 |
|
| 591 |
function parent_directory(path) result(parent) |
| 592 |
character(len=*), intent(in) :: path |
| 593 |
character(len=:), allocatable :: parent |
| 594 |
integer :: i |
| 595 |
integer :: slash_index |
| 596 |
|
| 597 |
slash_index = 0 |
| 598 |
do i = len(path), 1, -1 |
| 599 |
if (path(i:i) == "/") then |
| 600 |
slash_index = i |
| 601 |
exit |
| 602 |
end if |
| 603 |
end do |
| 604 |
|
| 605 |
if (slash_index == 0) then |
| 606 |
parent = "." |
| 607 |
else if (slash_index == 1) then |
| 608 |
parent = "/" |
| 609 |
else |
| 610 |
parent = path(:slash_index - 1) |
| 611 |
end if |
| 612 |
end function parent_directory |
| 613 |
|
| 614 |
logical function populate_entry_metadata(entry) result(success) |
| 615 |
type(cache_entry), intent(inout) :: entry |
| 616 |
integer :: sys_errno |
| 617 |
|
| 618 |
call clear_entry_metadata(entry) |
| 619 |
|
| 620 |
success = stat_path_posix(entry%path, entry%size_bytes, entry%modified_time_seconds, sys_errno) |
| 621 |
if (.not. success) then |
| 622 |
call set_entry_error(entry, FGOF_CACHE_ERR_IO, errno_message("cache entry metadata read failed", sys_errno)) |
| 623 |
return |
| 624 |
end if |
| 625 |
|
| 626 |
entry%metadata_available = .true. |
| 627 |
end function populate_entry_metadata |
| 628 |
|
| 629 |
subroutine refresh_entry_metadata(entry) |
| 630 |
type(cache_entry), intent(inout) :: entry |
| 631 |
|
| 632 |
if (.not. populate_entry_metadata(entry)) then |
| 633 |
entry%present = .true. |
| 634 |
entry%error_code = FGOF_CACHE_OK |
| 635 |
entry%error_message = "" |
| 636 |
end if |
| 637 |
end subroutine refresh_entry_metadata |
| 638 |
|
| 639 |
logical function inspect_entry(entry, strict_probe) result(success) |
| 640 |
type(cache_entry), intent(inout) :: entry |
| 641 |
logical, intent(in) :: strict_probe |
| 642 |
logical :: exists |
| 643 |
logical :: regular_file |
| 644 |
integer :: sys_errno |
| 645 |
|
| 646 |
entry%present = .false. |
| 647 |
call clear_entry_metadata(entry) |
| 648 |
|
| 649 |
success = path_probe_posix(entry%path, exists, regular_file, entry%size_bytes, & |
| 650 |
entry%modified_time_seconds, sys_errno) |
| 651 |
if (.not. success) then |
| 652 |
if (strict_probe) then |
| 653 |
call set_entry_error(entry, FGOF_CACHE_ERR_IO, errno_message("cache entry probe failed", sys_errno)) |
| 654 |
else |
| 655 |
entry%error_code = FGOF_CACHE_OK |
| 656 |
entry%error_message = "" |
| 657 |
success = .true. |
| 658 |
end if |
| 659 |
return |
| 660 |
end if |
| 661 |
|
| 662 |
if (.not. exists) then |
| 663 |
entry%error_code = FGOF_CACHE_OK |
| 664 |
entry%error_message = "" |
| 665 |
success = .true. |
| 666 |
return |
| 667 |
end if |
| 668 |
|
| 669 |
if (.not. regular_file) then |
| 670 |
call set_entry_error(entry, FGOF_CACHE_ERR_IO, "cache entry path exists but is not a regular file") |
| 671 |
success = .false. |
| 672 |
return |
| 673 |
end if |
| 674 |
|
| 675 |
entry%present = .true. |
| 676 |
entry%metadata_available = .true. |
| 677 |
entry%error_code = FGOF_CACHE_OK |
| 678 |
entry%error_message = "" |
| 679 |
success = .true. |
| 680 |
end function inspect_entry |
| 681 |
|
| 682 |
integer(int64) function effective_reference_time(reference_time_seconds) result(now_seconds) |
| 683 |
integer(int64), intent(in), optional :: reference_time_seconds |
| 684 |
|
| 685 |
if (present(reference_time_seconds)) then |
| 686 |
now_seconds = reference_time_seconds |
| 687 |
else |
| 688 |
now_seconds = current_time_seconds_posix() |
| 689 |
end if |
| 690 |
end function effective_reference_time |
| 691 |
|
| 692 |
integer(int64) function stale_cutoff(max_age_seconds, now_seconds) result(cutoff_seconds) |
| 693 |
integer(int64), intent(in) :: max_age_seconds |
| 694 |
integer(int64), intent(in) :: now_seconds |
| 695 |
|
| 696 |
if (now_seconds < max_age_seconds) then |
| 697 |
cutoff_seconds = -1_int64 |
| 698 |
else |
| 699 |
cutoff_seconds = now_seconds - max_age_seconds |
| 700 |
end if |
| 701 |
end function stale_cutoff |
| 702 |
|
| 703 |
logical function stale_from_times(modified_time_seconds, max_age_seconds, now_seconds) result(stale) |
| 704 |
integer(int64), intent(in) :: modified_time_seconds |
| 705 |
integer(int64), intent(in) :: max_age_seconds |
| 706 |
integer(int64), intent(in) :: now_seconds |
| 707 |
|
| 708 |
stale = (modified_time_seconds <= stale_cutoff(max_age_seconds, now_seconds)) |
| 709 |
end function stale_from_times |
| 710 |
|
| 711 |
subroutine read_text_file(path, text, error_code, error_message) |
| 712 |
character(len=*), intent(in) :: path |
| 713 |
character(len=:), allocatable, intent(out) :: text |
| 714 |
integer, intent(out) :: error_code |
| 715 |
character(len=:), allocatable, intent(out) :: error_message |
| 716 |
integer :: file_size |
| 717 |
integer :: ios |
| 718 |
integer :: unit |
| 719 |
character(len=256) :: iomsg |
| 720 |
|
| 721 |
error_code = FGOF_CACHE_OK |
| 722 |
error_message = "" |
| 723 |
|
| 724 |
inquire(file=path, size=file_size, iostat=ios, iomsg=iomsg) |
| 725 |
if (ios /= 0) then |
| 726 |
error_code = FGOF_CACHE_ERR_IO |
| 727 |
error_message = io_status_message("cache entry read failed while sizing file", ios, iomsg) |
| 728 |
text = "" |
| 729 |
return |
| 730 |
end if |
| 731 |
|
| 732 |
allocate(character(len=file_size) :: text) |
| 733 |
if (file_size == 0) return |
| 734 |
|
| 735 |
iomsg = "" |
| 736 |
open(newunit=unit, file=path, status="old", access="stream", form="unformatted", action="read", iostat=ios, iomsg=iomsg) |
| 737 |
if (ios /= 0) then |
| 738 |
error_code = FGOF_CACHE_ERR_IO |
| 739 |
error_message = io_status_message("cache entry read failed while opening file", ios, iomsg) |
| 740 |
deallocate(text) |
| 741 |
text = "" |
| 742 |
return |
| 743 |
end if |
| 744 |
|
| 745 |
iomsg = "" |
| 746 |
read(unit, iostat=ios, iomsg=iomsg) text |
| 747 |
if (ios /= 0) then |
| 748 |
close(unit) |
| 749 |
error_code = FGOF_CACHE_ERR_IO |
| 750 |
error_message = io_status_message("cache entry read failed while reading file", ios, iomsg) |
| 751 |
deallocate(text) |
| 752 |
text = "" |
| 753 |
return |
| 754 |
end if |
| 755 |
|
| 756 |
iomsg = "" |
| 757 |
close(unit, iostat=ios, iomsg=iomsg) |
| 758 |
if (ios /= 0) then |
| 759 |
error_code = FGOF_CACHE_ERR_IO |
| 760 |
error_message = io_status_message("cache entry read failed while closing file", ios, iomsg) |
| 761 |
deallocate(text) |
| 762 |
text = "" |
| 763 |
end if |
| 764 |
end subroutine read_text_file |
| 765 |
|
| 766 |
subroutine set_root_error(root, code, message) |
| 767 |
type(cache_root), intent(inout) :: root |
| 768 |
integer, intent(in) :: code |
| 769 |
character(len=*), intent(in) :: message |
| 770 |
|
| 771 |
root%ready = .false. |
| 772 |
root%error_code = code |
| 773 |
root%error_message = message |
| 774 |
end subroutine set_root_error |
| 775 |
|
| 776 |
subroutine set_entry_error(entry, code, message) |
| 777 |
type(cache_entry), intent(inout) :: entry |
| 778 |
integer, intent(in) :: code |
| 779 |
character(len=*), intent(in) :: message |
| 780 |
|
| 781 |
entry%present = .false. |
| 782 |
call clear_entry_metadata(entry) |
| 783 |
entry%error_code = code |
| 784 |
entry%error_message = message |
| 785 |
end subroutine set_entry_error |
| 786 |
|
| 787 |
subroutine clear_entry_metadata(entry) |
| 788 |
type(cache_entry), intent(inout) :: entry |
| 789 |
|
| 790 |
entry%metadata_available = .false. |
| 791 |
entry%size_bytes = 0_int64 |
| 792 |
entry%modified_time_seconds = 0_int64 |
| 793 |
end subroutine clear_entry_metadata |
| 794 |
|
| 795 |
subroutine set_prune_error(result_value, code, message) |
| 796 |
type(cache_prune_result), intent(inout) :: result_value |
| 797 |
integer, intent(in) :: code |
| 798 |
character(len=*), intent(in) :: message |
| 799 |
|
| 800 |
result_value%completed = .false. |
| 801 |
result_value%error_code = code |
| 802 |
result_value%error_message = message |
| 803 |
end subroutine set_prune_error |
| 804 |
|
| 805 |
function io_status_message(prefix, status_code, iomsg) result(message) |
| 806 |
character(len=*), intent(in) :: prefix |
| 807 |
integer, intent(in) :: status_code |
| 808 |
character(len=*), intent(in) :: iomsg |
| 809 |
character(len=:), allocatable :: message |
| 810 |
character(len=32) :: status_text |
| 811 |
|
| 812 |
write(status_text, "(i0)") status_code |
| 813 |
if (len_trim(iomsg) > 0) then |
| 814 |
message = prefix // " (iostat=" // trim(status_text) // ", " // trim(iomsg) // ")" |
| 815 |
else |
| 816 |
message = prefix // " (iostat=" // trim(status_text) // ")" |
| 817 |
end if |
| 818 |
end function io_status_message |
| 819 |
|
| 820 |
function errno_message(prefix, sys_errno) result(message) |
| 821 |
character(len=*), intent(in) :: prefix |
| 822 |
integer, intent(in) :: sys_errno |
| 823 |
character(len=:), allocatable :: message |
| 824 |
character(len=32) :: errno_text |
| 825 |
|
| 826 |
write(errno_text, "(i0)") sys_errno |
| 827 |
message = prefix // " (errno=" // trim(errno_text) // ")" |
| 828 |
end function errno_message |
| 829 |
|
| 830 |
end module fgof_cache |
| 831 |
|