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