1#! /usr/bin/env perl 2# Copyright 2016-2023 The OpenSSL Project Authors. All Rights Reserved. 3# 4# Licensed under the Apache License 2.0 (the "License"). You may not use 5# this file except in compliance with the License. You can obtain a copy 6# in the file LICENSE in the source distribution or at 7# https://www.openssl.org/source/license.html 8 9use File::Spec::Functions; 10use File::Copy; 11use MIME::Base64; 12use OpenSSL::Test qw(:DEFAULT srctop_file srctop_dir bldtop_file bldtop_dir 13 data_file); 14use OpenSSL::Test::Utils; 15 16my $test_name = "test_store"; 17setup($test_name); 18 19my $use_md5 = !disabled("md5"); 20my $use_des = !(disabled("des") || disabled("legacy")); # also affects 3des and pkcs12 app 21my $use_dsa = !disabled("dsa"); 22my $use_ecc = !disabled("ec"); 23 24my @noexist_files = 25 ( "test/blahdiblah.pem", 26 "test/blahdibleh.der" ); 27my @src_files = 28 ( "test/testx509.pem", 29 "test/testrsa.pem", 30 "test/testrsapub.pem", 31 "test/testcrl.pem", 32 "apps/server.pem" ); 33my @data_files = 34 ( "testrsa.msb" ); 35push(@data_files, 36 ( "testrsa.pvk" )) 37 unless disabled("legacy") || disabled("rc4"); 38my @src_rsa_files = 39 ( "test/testrsa.pem", 40 "test/testrsapub.pem" ); 41my @generated_files = 42 ( 43 ### generated from the source files 44 45 "testx509.der", 46 "testrsa.der", 47 "testrsapub.der", 48 "testcrl.der", 49 50 ### generated locally 51 52 "rsa-key-pkcs1.pem", "rsa-key-pkcs1.der", 53 "rsa-key-pkcs1-aes128.pem", 54 "rsa-key-pkcs8.pem", "rsa-key-pkcs8.der", 55 "rsa-key-pkcs8-pbes2-sha1.pem", "rsa-key-pkcs8-pbes2-sha1.der", 56 "rsa-key-pkcs8-pbes2-sha256.pem", "rsa-key-pkcs8-pbes2-sha256.der", 57 ); 58push(@generated_files, ( 59 "rsa-key-pkcs8-pbes1-sha1-3des.pem", "rsa-key-pkcs8-pbes1-sha1-3des.der", 60 )) if $use_des; 61push(@generated_files, ( 62 "rsa-key-sha1-3des-sha1.p12", "rsa-key-sha1-3des-sha256.p12", 63 "rsa-key-aes256-cbc-sha256.p12", 64 "rsa-key-md5-des-sha1.p12", 65 "rsa-key-aes256-cbc-md5-des-sha256.p12" 66 )) if $use_des; 67push(@generated_files, ( 68 "rsa-key-pkcs8-pbes1-md5-des.pem", "rsa-key-pkcs8-pbes1-md5-des.der" 69 )) if $use_md5 && $use_des; 70push(@generated_files, ( 71 "dsa-key-pkcs1.pem", "dsa-key-pkcs1.der", 72 "dsa-key-pkcs1-aes128.pem", 73 "dsa-key-pkcs8.pem", "dsa-key-pkcs8.der", 74 "dsa-key-pkcs8-pbes2-sha1.pem", "dsa-key-pkcs8-pbes2-sha1.der", 75 )) if $use_dsa; 76push(@generated_files, "dsa-key-aes256-cbc-sha256.p12") if $use_dsa && $use_des; 77push(@generated_files, ( 78 "ec-key-pkcs1.pem", "ec-key-pkcs1.der", 79 "ec-key-pkcs1-aes128.pem", 80 "ec-key-pkcs8.pem", "ec-key-pkcs8.der", 81 "ec-key-pkcs8-pbes2-sha1.pem", "ec-key-pkcs8-pbes2-sha1.der", 82 )) if $use_ecc; 83push(@generated_files, "ec-key-aes256-cbc-sha256.p12") if $use_ecc && $use_des; 84my %generated_file_files = 85 $^O eq 'linux' 86 ? ( "test/testx509.pem" => "file:testx509.pem", 87 "test/testrsa.pem" => "file:testrsa.pem", 88 "test/testrsapub.pem" => "file:testrsapub.pem", 89 "test/testcrl.pem" => "file:testcrl.pem", 90 "apps/server.pem" => "file:server.pem" ) 91 : (); 92my @noexist_file_files = 93 ( "file:blahdiblah.pem", 94 "file:test/blahdibleh.der" ); 95 96# There is more than one method to get a 'file:' loader. 97# The default is a built-in provider implementation. 98# However, there is also an engine, specially for testing purposes. 99# 100# @methods is a collection of extra 'openssl storeutl' arguments used to 101# try the different methods. 102my @methods; 103my @prov_method = qw(-provider default); 104push @prov_method, qw(-provider legacy) unless disabled('legacy'); 105push @methods, [ @prov_method ]; 106push @methods, [qw(-engine loader_attic)] 107 unless disabled('loadereng'); 108 109my $n = 2 + scalar @methods 110 * ( (3 * scalar @noexist_files) 111 + (6 * scalar @src_files) 112 + (2 * scalar @data_files) 113 + (4 * scalar @generated_files) 114 + (scalar keys %generated_file_files) 115 + (scalar @noexist_file_files) 116 + 3 117 + 11 ); 118 119# Test doesn't work under msys because the file name munging doesn't work 120# correctly with the "ot:" prefix 121my $do_test_ossltest_store = 122 !(disabled("engine") || disabled("dynamic-engine") || $^O =~ /^msys$/); 123 124if ($do_test_ossltest_store) { 125 # test loading with apps 'org.openssl.engine:' loader, using the 126 # ossltest engine. 127 $n += 4 * scalar @src_rsa_files; 128} 129 130plan skip_all => "No plan" if $n == 0; 131 132plan tests => $n; 133 134my $test_x509 = srctop_file('test', 'testx509.pem'); 135 136ok(run(app(["openssl", "storeutl", "-crls", $test_x509])), 137 "storeutil with -crls option"); 138 139ok(!run(app(["openssl", "storeutl", $test_x509, "-crls"])), 140 "storeutil with extra parameter (at end) should fail"); 141 142indir "store_$$" => sub { 143 if ($do_test_ossltest_store) { 144 # ossltest loads PEM files, with names prefixed with 'ot:'. 145 # This prefix ensures that the files are, in fact, loaded through 146 # that engine and not mistakenly going through the 'file:' loader. 147 148 my $engine_scheme = 'org.openssl.engine:'; 149 $ENV{OPENSSL_ENGINES} = bldtop_dir("engines"); 150 151 foreach (@src_rsa_files) { 152 my $file = srctop_file($_); 153 my $file_abs = to_abs_file($file); 154 my @pubin = $_ =~ m|pub\.pem$| ? ("-pubin") : (); 155 156 ok(run(app(["openssl", "rsa", "-text", "-noout", @pubin, 157 "-engine", "ossltest", "-inform", "engine", 158 "-in", "ot:$file"]))); 159 ok(run(app(["openssl", "rsa", "-text", "-noout", @pubin, 160 "-engine", "ossltest", "-inform", "engine", 161 "-in", "ot:$file_abs"]))); 162 ok(run(app(["openssl", "rsa", "-text", "-noout", @pubin, 163 "-in", "${engine_scheme}ossltest:ot:$file"]))); 164 ok(run(app(["openssl", "rsa", "-text", "-noout", @pubin, 165 "-in", "${engine_scheme}ossltest:ot:$file_abs"]))); 166 } 167 } 168 169 SKIP: 170 { 171 init() or die "init failed"; 172 173 my $rehash = init_rehash(); 174 175 foreach my $method (@methods) { 176 my @storeutl = ( qw(openssl storeutl), @$method ); 177 178 foreach (@noexist_files) { 179 my $file = srctop_file($_); 180 181 ok(!run(app([@storeutl, "-noout", $file]))); 182 ok(!run(app([@storeutl, "-noout", to_abs_file($file)]))); 183 { 184 local $ENV{MSYS2_ARG_CONV_EXCL} = "file:"; 185 186 ok(!run(app([@storeutl, "-noout", 187 to_abs_file_uri($file)]))); 188 } 189 } 190 foreach (@src_files) { 191 my $file = srctop_file($_); 192 193 ok(run(app([@storeutl, "-noout", $file]))); 194 ok(run(app([@storeutl, "-noout", to_abs_file($file)]))); 195 SKIP: 196 { 197 skip "file: tests disabled on MingW", 4 if $^O =~ /^msys$/; 198 199 ok(run(app([@storeutl, "-noout", 200 to_abs_file_uri($file)]))); 201 ok(run(app([@storeutl, "-noout", 202 to_abs_file_uri($file, 0, "")]))); 203 ok(run(app([@storeutl, "-noout", 204 to_abs_file_uri($file, 0, "localhost")]))); 205 ok(!run(app([@storeutl, "-noout", 206 to_abs_file_uri($file, 0, "dummy")]))); 207 } 208 } 209 foreach (@data_files) { 210 my $file = data_file($_); 211 212 ok(run(app([@storeutl, "-noout", "-passin", "pass:password", 213 $file]))); 214 ok(run(app([@storeutl, "-noout", "-passin", "pass:password", 215 to_abs_file($file)]))); 216 } 217 foreach (@generated_files) { 218 ok(run(app([@storeutl, "-noout", "-passin", "pass:password", 219 $_]))); 220 ok(run(app([@storeutl, "-noout", "-passin", "pass:password", 221 to_abs_file($_)]))); 222 223 SKIP: 224 { 225 skip "file: tests disabled on MingW", 2 if $^O =~ /^msys$/; 226 227 ok(run(app([@storeutl, "-noout", "-passin", 228 "pass:password", to_abs_file_uri($_)]))); 229 ok(!run(app([@storeutl, "-noout", "-passin", 230 "pass:password", to_file_uri($_)]))); 231 } 232 } 233 foreach (values %generated_file_files) { 234 SKIP: 235 { 236 skip "file: tests disabled on MingW", 1 if $^O =~ /^msys$/; 237 238 ok(run(app([@storeutl, "-noout", $_]))); 239 } 240 } 241 foreach (@noexist_file_files) { 242 SKIP: 243 { 244 skip "file: tests disabled on MingW", 1 if $^O =~ /^msys$/; 245 246 ok(!run(app([@storeutl, "-noout", $_]))); 247 } 248 } 249 { 250 my $dir = srctop_dir("test", "certs"); 251 252 ok(run(app([@storeutl, "-noout", $dir]))); 253 ok(run(app([@storeutl, "-noout", to_abs_file($dir, 1)]))); 254 SKIP: 255 { 256 skip "file: tests disabled on MingW", 1 if $^O =~ /^msys$/; 257 258 ok(run(app([@storeutl, "-noout", 259 to_abs_file_uri($dir, 1)]))); 260 } 261 } 262 263 ok(!run(app([@storeutl, '-noout', 264 '-subject', '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert', 265 srctop_file('test', 'testx509.pem')])), 266 "Checking that -subject can't be used with a single file"); 267 268 ok(run(app([@storeutl, '-certs', '-noout', 269 srctop_file('test', 'testx509.pem')])), 270 "Checking that -certs returns 1 object on a certificate file"); 271 ok(run(app([@storeutl, '-certs', '-noout', 272 srctop_file('test', 'testcrl.pem')])), 273 "Checking that -certs returns 0 objects on a CRL file"); 274 275 ok(run(app([@storeutl, '-crls', '-noout', 276 srctop_file('test', 'testx509.pem')])), 277 "Checking that -crls returns 0 objects on a certificate file"); 278 ok(run(app([@storeutl, '-crls', '-noout', 279 srctop_file('test', 'testcrl.pem')])), 280 "Checking that -crls returns 1 object on a CRL file"); 281 282 SKIP: { 283 skip "failed rehash initialisation", 6 unless $rehash; 284 285 # subject from testx509.pem: 286 # '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert' 287 # issuer from testcrl.pem: 288 # '/C=US/O=RSA Data Security, Inc./OU=Secure Server Certification Authority' 289 ok(run(app([@storeutl, '-noout', 290 '-subject', '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert', 291 catdir(curdir(), 'rehash')]))); 292 ok(run(app([@storeutl, '-noout', 293 '-subject', 294 '/C=US/O=RSA Data Security, Inc./OU=Secure Server Certification Authority', 295 catdir(curdir(), 'rehash')]))); 296 ok(run(app([@storeutl, '-noout', '-certs', 297 '-subject', '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert', 298 catdir(curdir(), 'rehash')]))); 299 ok(run(app([@storeutl, '-noout', '-crls', 300 '-subject', '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert', 301 catdir(curdir(), 'rehash')]))); 302 ok(run(app([@storeutl, '-noout', '-certs', 303 '-subject', 304 '/C=US/O=RSA Data Security, Inc./OU=Secure Server Certification Authority', 305 catdir(curdir(), 'rehash')]))); 306 ok(run(app([@storeutl, '-noout', '-crls', 307 '-subject', 308 '/C=US/O=RSA Data Security, Inc./OU=Secure Server Certification Authority', 309 catdir(curdir(), 'rehash')]))); 310 } 311 } 312 } 313}, create => 1, cleanup => 1; 314 315sub init { 316 my $cnf = srctop_file('test', 'ca-and-certs.cnf'); 317 my $cakey = srctop_file('test', 'certs', 'ca-key.pem'); 318 my @std_args = qw(-provider default); 319 push @std_args, qw(-provider legacy) 320 unless disabled('legacy'); 321 return ( 322 # rsa-key-pkcs1.pem 323 run(app(["openssl", "pkey", @std_args, 324 "-in", data_file("rsa-key-2432.pem"), 325 "-out", "rsa-key-pkcs1.pem"])) 326 # rsa-key-pkcs1-aes128.pem 327 && run(app(["openssl", "rsa", @std_args, 328 "-passout", "pass:password", "-aes128", 329 "-in", "rsa-key-pkcs1.pem", 330 "-out", "rsa-key-pkcs1-aes128.pem"])) 331 # dsa-key-pkcs1.pem 332 && (!$use_dsa 333 || run(app(["openssl", "gendsa", @std_args, 334 "-out", "dsa-key-pkcs1.pem", 335 data_file("dsaparam.pem")]))) 336 # dsa-key-pkcs1-aes128.pem 337 && (!$use_dsa 338 || run(app(["openssl", "dsa", @std_args, 339 "-passout", "pass:password", "-aes128", 340 "-in", "dsa-key-pkcs1.pem", 341 "-out", "dsa-key-pkcs1-aes128.pem"]))) 342 # ec-key-pkcs1.pem (one might think that 'genec' would be practical) 343 && (!$use_ecc 344 || run(app(["openssl", "ecparam", @std_args, 345 "-genkey", 346 "-name", "prime256v1", 347 "-out", "ec-key-pkcs1.pem"]))) 348 # ec-key-pkcs1-aes128.pem 349 && (!$use_ecc 350 || run(app(["openssl", "ec", @std_args, 351 "-passout", "pass:password", "-aes128", 352 "-in", "ec-key-pkcs1.pem", 353 "-out", "ec-key-pkcs1-aes128.pem"]))) 354 # *-key-pkcs8.pem 355 && runall(sub { 356 my $dstfile = shift; 357 (my $srcfile = $dstfile) 358 =~ s/-key-pkcs8\.pem$/-key-pkcs1.pem/i; 359 run(app(["openssl", "pkcs8", @std_args, 360 "-topk8", "-nocrypt", 361 "-in", $srcfile, "-out", $dstfile])); 362 }, grep(/-key-pkcs8\.pem$/, @generated_files)) 363 # *-key-pkcs8-pbes1-sha1-3des.pem 364 && runall(sub { 365 my $dstfile = shift; 366 (my $srcfile = $dstfile) 367 =~ s/-key-pkcs8-pbes1-sha1-3des\.pem$ 368 /-key-pkcs8.pem/ix; 369 run(app(["openssl", "pkcs8", @std_args, 370 "-topk8", 371 "-passout", "pass:password", 372 "-v1", "pbeWithSHA1And3-KeyTripleDES-CBC", 373 "-in", $srcfile, "-out", $dstfile])); 374 }, grep(/-key-pkcs8-pbes1-sha1-3des\.pem$/, @generated_files)) 375 # *-key-pkcs8-pbes1-md5-des.pem 376 && runall(sub { 377 my $dstfile = shift; 378 (my $srcfile = $dstfile) 379 =~ s/-key-pkcs8-pbes1-md5-des\.pem$ 380 /-key-pkcs8.pem/ix; 381 run(app(["openssl", "pkcs8", @std_args, 382 "-topk8", 383 "-passout", "pass:password", 384 "-v1", "pbeWithSHA1And3-KeyTripleDES-CBC", 385 "-in", $srcfile, "-out", $dstfile])); 386 }, grep(/-key-pkcs8-pbes1-md5-des\.pem$/, @generated_files)) 387 # *-key-pkcs8-pbes2-sha1.pem 388 && runall(sub { 389 my $dstfile = shift; 390 (my $srcfile = $dstfile) 391 =~ s/-key-pkcs8-pbes2-sha1\.pem$ 392 /-key-pkcs8.pem/ix; 393 run(app(["openssl", "pkcs8", @std_args, 394 "-topk8", 395 "-passout", "pass:password", 396 "-v2", "aes256", "-v2prf", "hmacWithSHA1", 397 "-in", $srcfile, "-out", $dstfile])); 398 }, grep(/-key-pkcs8-pbes2-sha1\.pem$/, @generated_files)) 399 # *-key-pkcs8-pbes2-sha1.pem 400 && runall(sub { 401 my $dstfile = shift; 402 (my $srcfile = $dstfile) 403 =~ s/-key-pkcs8-pbes2-sha256\.pem$ 404 /-key-pkcs8.pem/ix; 405 run(app(["openssl", "pkcs8", @std_args, 406 "-topk8", 407 "-passout", "pass:password", 408 "-v2", "aes256", "-v2prf", "hmacWithSHA256", 409 "-in", $srcfile, "-out", $dstfile])); 410 }, grep(/-key-pkcs8-pbes2-sha256\.pem$/, @generated_files)) 411 # *-cert.pem (intermediary for the .p12 inits) 412 && run(app(["openssl", "req", "-x509", @std_args, 413 "-config", $cnf, "-reqexts", "v3_ca", "-noenc", 414 "-key", $cakey, "-out", "cacert.pem"])) 415 && runall(sub { 416 my $srckey = shift; 417 (my $dstfile = $srckey) =~ s|-key-pkcs8\.|-cert.|; 418 (my $csr = $dstfile) =~ s|\.pem|.csr|; 419 420 (run(app(["openssl", "req", "-new", @std_args, 421 "-config", $cnf, "-section", "userreq", 422 "-key", $srckey, "-out", $csr])) 423 && 424 run(app(["openssl", "x509", @std_args, 425 "-days", "3650", 426 "-CA", "cacert.pem", 427 "-CAkey", $cakey, 428 "-set_serial", time(), "-req", 429 "-in", $csr, "-out", $dstfile]))); 430 }, grep(/-key-pkcs8\.pem$/, @generated_files)) 431 # *.p12 432 && runall(sub { 433 my $dstfile = shift; 434 my ($type, $certpbe_index, $keypbe_index, 435 $macalg_index) = 436 $dstfile =~ m{^(.*)-key-(?| 437 # cert and key PBE are same 438 () # 439 ([^-]*-[^-]*)- # key & cert PBE 440 ([^-]*) # MACalg 441 | 442 # cert and key PBE are not same 443 ([^-]*-[^-]*)- # cert PBE 444 ([^-]*-[^-]*)- # key PBE 445 ([^-]*) # MACalg 446 )\.}x; 447 if (!$certpbe_index) { 448 $certpbe_index = $keypbe_index; 449 } 450 my $srckey = "$type-key-pkcs8.pem"; 451 my $srccert = "$type-cert.pem"; 452 my %pbes = 453 ( 454 "sha1-3des" => "pbeWithSHA1And3-KeyTripleDES-CBC", 455 "md5-des" => "pbeWithMD5AndDES-CBC", 456 "aes256-cbc" => "AES-256-CBC", 457 ); 458 my %macalgs = 459 ( 460 "sha1" => "SHA1", 461 "sha256" => "SHA256", 462 ); 463 my $certpbe = $pbes{$certpbe_index}; 464 my $keypbe = $pbes{$keypbe_index}; 465 my $macalg = $macalgs{$macalg_index}; 466 if (!defined($certpbe) || !defined($keypbe) 467 || !defined($macalg)) { 468 print STDERR "Cert PBE for $certpbe_index not defined\n" 469 unless defined $certpbe; 470 print STDERR "Key PBE for $keypbe_index not defined\n" 471 unless defined $keypbe; 472 print STDERR "MACALG for $macalg_index not defined\n" 473 unless defined $macalg; 474 print STDERR "(destination file was $dstfile)\n"; 475 return 0; 476 } 477 run(app(["openssl", "pkcs12", @std_args, 478 "-inkey", $srckey, 479 "-in", $srccert, "-passout", "pass:password", 480 "-chain", "-CAfile", "cacert.pem", 481 "-export", "-macalg", $macalg, 482 "-certpbe", $certpbe, "-keypbe", $keypbe, 483 "-out", $dstfile])); 484 }, grep(/\.p12/, @generated_files)) 485 # *.der (the end all init) 486 && runall(sub { 487 my $dstfile = shift; 488 (my $srcfile = $dstfile) =~ s/\.der$/.pem/i; 489 if (! -f $srcfile) { 490 $srcfile = srctop_file("test", $srcfile); 491 } 492 my $infh; 493 unless (open $infh, $srcfile) { 494 return 0; 495 } 496 my $l; 497 while (($l = <$infh>) !~ /^-----BEGIN\s/ 498 || $l =~ /^-----BEGIN.*PARAMETERS-----/) { 499 } 500 my $b64 = ""; 501 while (($l = <$infh>) !~ /^-----END\s/) { 502 $l =~ s|\R$||; 503 $b64 .= $l unless $l =~ /:/; 504 } 505 close $infh; 506 my $der = decode_base64($b64); 507 unless (length($b64) / 4 * 3 - length($der) < 3) { 508 print STDERR "Length error, ",length($b64), 509 " bytes of base64 became ",length($der), 510 " bytes of der? ($srcfile => $dstfile)\n"; 511 return 0; 512 } 513 my $outfh; 514 unless (open $outfh, ">:raw", $dstfile) { 515 return 0; 516 } 517 print $outfh $der; 518 close $outfh; 519 return 1; 520 }, grep(/\.der$/, @generated_files)) 521 && runall(sub { 522 my $srcfile = shift; 523 my $dstfile = $generated_file_files{$srcfile}; 524 525 unless (copy srctop_file($srcfile), $dstfile) { 526 warn "$!\n"; 527 return 0; 528 } 529 return 1; 530 }, keys %generated_file_files) 531 ); 532} 533 534sub init_rehash { 535 return ( 536 mkdir(catdir(curdir(), 'rehash')) 537 && copy(srctop_file('test', 'testx509.pem'), 538 catdir(curdir(), 'rehash')) 539 && copy(srctop_file('test', 'testcrl.pem'), 540 catdir(curdir(), 'rehash')) 541 && run(app(['openssl', 'rehash', catdir(curdir(), 'rehash')])) 542 ); 543} 544 545sub runall { 546 my ($function, @items) = @_; 547 548 foreach (@items) { 549 return 0 unless $function->($_); 550 } 551 return 1; 552} 553 554# According to RFC8089, a relative file: path is invalid. We still produce 555# them for testing purposes. 556sub to_file_uri { 557 my ($file, $isdir, $authority) = @_; 558 my $vol; 559 my $dir; 560 561 die "to_file_uri: No file given\n" if !defined($file) || $file eq ''; 562 563 ($vol, $dir, $file) = File::Spec->splitpath($file, $isdir // 0); 564 565 # Make sure we have a Unix style directory. 566 $dir = join('/', File::Spec->splitdir($dir)); 567 # Canonicalise it (note: it seems to be only needed on Unix) 568 while (1) { 569 my $newdir = $dir; 570 $newdir =~ s|/[^/]*[^/\.]+[^/]*/\.\./|/|g; 571 last if $newdir eq $dir; 572 $dir = $newdir; 573 } 574 # Take care of the corner cases the loop can't handle, and that $dir 575 # ends with a / unless it's empty 576 $dir =~ s|/[^/]*[^/\.]+[^/]*/\.\.$|/|; 577 $dir =~ s|^[^/]*[^/\.]+[^/]*/\.\./|/|; 578 $dir =~ s|^[^/]*[^/\.]+[^/]*/\.\.$||; 579 if ($isdir // 0) { 580 $dir =~ s|/$|| if $dir ne '/'; 581 } else { 582 $dir .= '/' if $dir ne '' && $dir !~ m|/$|; 583 } 584 585 # If the file system has separate volumes (at present, Windows and VMS) 586 # we need to handle them. In URIs, they are invariably the first 587 # component of the path, which is always absolute. 588 # On VMS, user:[foo.bar] translates to /user/foo/bar 589 # On Windows, c:\Users\Foo translates to /c:/Users/Foo 590 if ($vol ne '') { 591 $vol =~ s|:||g if ($^O eq "VMS"); 592 $dir = '/' . $dir if $dir ne '' && $dir !~ m|^/|; 593 $dir = '/' . $vol . $dir; 594 } 595 $file = $dir . $file; 596 597 return "file://$authority$file" if defined $authority; 598 return "file:$file"; 599} 600 601sub to_abs_file { 602 my ($file) = @_; 603 604 return File::Spec->rel2abs($file); 605} 606 607sub to_abs_file_uri { 608 my ($file, $isdir, $authority) = @_; 609 610 die "to_abs_file_uri: No file given\n" if !defined($file) || $file eq ''; 611 return to_file_uri(to_abs_file($file), $isdir, $authority); 612} 613
