1#! /usr/bin/env perl 2# Copyright 2016-2021 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 = 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 134indir "store_$$" => sub { 135 if ($do_test_ossltest_store) { 136 # ossltest loads PEM files, with names prefixed with 'ot:'. 137 # This prefix ensures that the files are, in fact, loaded through 138 # that engine and not mistakenly going through the 'file:' loader. 139 140 my $engine_scheme = 'org.openssl.engine:'; 141 $ENV{OPENSSL_ENGINES} = bldtop_dir("engines"); 142 143 foreach (@src_rsa_files) { 144 my $file = srctop_file($_); 145 my $file_abs = to_abs_file($file); 146 my @pubin = $_ =~ m|pub\.pem$| ? ("-pubin") : (); 147 148 ok(run(app(["openssl", "rsa", "-text", "-noout", @pubin, 149 "-engine", "ossltest", "-inform", "engine", 150 "-in", "ot:$file"]))); 151 ok(run(app(["openssl", "rsa", "-text", "-noout", @pubin, 152 "-engine", "ossltest", "-inform", "engine", 153 "-in", "ot:$file_abs"]))); 154 ok(run(app(["openssl", "rsa", "-text", "-noout", @pubin, 155 "-in", "${engine_scheme}ossltest:ot:$file"]))); 156 ok(run(app(["openssl", "rsa", "-text", "-noout", @pubin, 157 "-in", "${engine_scheme}ossltest:ot:$file_abs"]))); 158 } 159 } 160 161 SKIP: 162 { 163 init() or die "init failed"; 164 165 my $rehash = init_rehash(); 166 167 foreach my $method (@methods) { 168 my @storeutl = ( qw(openssl storeutl), @$method ); 169 170 foreach (@noexist_files) { 171 my $file = srctop_file($_); 172 173 ok(!run(app([@storeutl, "-noout", $file]))); 174 ok(!run(app([@storeutl, "-noout", to_abs_file($file)]))); 175 { 176 local $ENV{MSYS2_ARG_CONV_EXCL} = "file:"; 177 178 ok(!run(app([@storeutl, "-noout", 179 to_abs_file_uri($file)]))); 180 } 181 } 182 foreach (@src_files) { 183 my $file = srctop_file($_); 184 185 ok(run(app([@storeutl, "-noout", $file]))); 186 ok(run(app([@storeutl, "-noout", to_abs_file($file)]))); 187 SKIP: 188 { 189 skip "file: tests disabled on MingW", 4 if $^O =~ /^msys$/; 190 191 ok(run(app([@storeutl, "-noout", 192 to_abs_file_uri($file)]))); 193 ok(run(app([@storeutl, "-noout", 194 to_abs_file_uri($file, 0, "")]))); 195 ok(run(app([@storeutl, "-noout", 196 to_abs_file_uri($file, 0, "localhost")]))); 197 ok(!run(app([@storeutl, "-noout", 198 to_abs_file_uri($file, 0, "dummy")]))); 199 } 200 } 201 foreach (@data_files) { 202 my $file = data_file($_); 203 204 ok(run(app([@storeutl, "-noout", "-passin", "pass:password", 205 $file]))); 206 ok(run(app([@storeutl, "-noout", "-passin", "pass:password", 207 to_abs_file($file)]))); 208 } 209 foreach (@generated_files) { 210 ok(run(app([@storeutl, "-noout", "-passin", "pass:password", 211 $_]))); 212 ok(run(app([@storeutl, "-noout", "-passin", "pass:password", 213 to_abs_file($_)]))); 214 215 SKIP: 216 { 217 skip "file: tests disabled on MingW", 2 if $^O =~ /^msys$/; 218 219 ok(run(app([@storeutl, "-noout", "-passin", 220 "pass:password", to_abs_file_uri($_)]))); 221 ok(!run(app([@storeutl, "-noout", "-passin", 222 "pass:password", to_file_uri($_)]))); 223 } 224 } 225 foreach (values %generated_file_files) { 226 SKIP: 227 { 228 skip "file: tests disabled on MingW", 1 if $^O =~ /^msys$/; 229 230 ok(run(app([@storeutl, "-noout", $_]))); 231 } 232 } 233 foreach (@noexist_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 { 242 my $dir = srctop_dir("test", "certs"); 243 244 ok(run(app([@storeutl, "-noout", $dir]))); 245 ok(run(app([@storeutl, "-noout", to_abs_file($dir, 1)]))); 246 SKIP: 247 { 248 skip "file: tests disabled on MingW", 1 if $^O =~ /^msys$/; 249 250 ok(run(app([@storeutl, "-noout", 251 to_abs_file_uri($dir, 1)]))); 252 } 253 } 254 255 ok(!run(app([@storeutl, '-noout', 256 '-subject', '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert', 257 srctop_file('test', 'testx509.pem')])), 258 "Checking that -subject can't be used with a single file"); 259 260 ok(run(app([@storeutl, '-certs', '-noout', 261 srctop_file('test', 'testx509.pem')])), 262 "Checking that -certs returns 1 object on a certificate file"); 263 ok(run(app([@storeutl, '-certs', '-noout', 264 srctop_file('test', 'testcrl.pem')])), 265 "Checking that -certs returns 0 objects on a CRL file"); 266 267 ok(run(app([@storeutl, '-crls', '-noout', 268 srctop_file('test', 'testx509.pem')])), 269 "Checking that -crls returns 0 objects on a certificate file"); 270 ok(run(app([@storeutl, '-crls', '-noout', 271 srctop_file('test', 'testcrl.pem')])), 272 "Checking that -crls returns 1 object on a CRL file"); 273 274 SKIP: { 275 skip "failed rehash initialisation", 6 unless $rehash; 276 277 # subject from testx509.pem: 278 # '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert' 279 # issuer from testcrl.pem: 280 # '/C=US/O=RSA Data Security, Inc./OU=Secure Server Certification Authority' 281 ok(run(app([@storeutl, '-noout', 282 '-subject', '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert', 283 catdir(curdir(), 'rehash')]))); 284 ok(run(app([@storeutl, '-noout', 285 '-subject', 286 '/C=US/O=RSA Data Security, Inc./OU=Secure Server Certification Authority', 287 catdir(curdir(), 'rehash')]))); 288 ok(run(app([@storeutl, '-noout', '-certs', 289 '-subject', '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert', 290 catdir(curdir(), 'rehash')]))); 291 ok(run(app([@storeutl, '-noout', '-crls', 292 '-subject', '/C=AU/ST=QLD/CN=SSLeay\/rsa test cert', 293 catdir(curdir(), 'rehash')]))); 294 ok(run(app([@storeutl, '-noout', '-certs', 295 '-subject', 296 '/C=US/O=RSA Data Security, Inc./OU=Secure Server Certification Authority', 297 catdir(curdir(), 'rehash')]))); 298 ok(run(app([@storeutl, '-noout', '-crls', 299 '-subject', 300 '/C=US/O=RSA Data Security, Inc./OU=Secure Server Certification Authority', 301 catdir(curdir(), 'rehash')]))); 302 } 303 } 304 } 305}, create => 1, cleanup => 1; 306 307sub init { 308 my $cnf = srctop_file('test', 'ca-and-certs.cnf'); 309 my $cakey = srctop_file('test', 'certs', 'ca-key.pem'); 310 my @std_args = qw(-provider default); 311 push @std_args, qw(-provider legacy) 312 unless disabled('legacy'); 313 return ( 314 # rsa-key-pkcs1.pem 315 run(app(["openssl", "pkey", @std_args, 316 "-in", data_file("rsa-key-2432.pem"), 317 "-out", "rsa-key-pkcs1.pem"])) 318 # rsa-key-pkcs1-aes128.pem 319 && run(app(["openssl", "rsa", @std_args, 320 "-passout", "pass:password", "-aes128", 321 "-in", "rsa-key-pkcs1.pem", 322 "-out", "rsa-key-pkcs1-aes128.pem"])) 323 # dsa-key-pkcs1.pem 324 && (!$use_dsa 325 || run(app(["openssl", "gendsa", @std_args, 326 "-out", "dsa-key-pkcs1.pem", 327 data_file("dsaparam.pem")]))) 328 # dsa-key-pkcs1-aes128.pem 329 && (!$use_dsa 330 || run(app(["openssl", "dsa", @std_args, 331 "-passout", "pass:password", "-aes128", 332 "-in", "dsa-key-pkcs1.pem", 333 "-out", "dsa-key-pkcs1-aes128.pem"]))) 334 # ec-key-pkcs1.pem (one might think that 'genec' would be practical) 335 && (!$use_ecc 336 || run(app(["openssl", "ecparam", @std_args, 337 "-genkey", 338 "-name", "prime256v1", 339 "-out", "ec-key-pkcs1.pem"]))) 340 # ec-key-pkcs1-aes128.pem 341 && (!$use_ecc 342 || run(app(["openssl", "ec", @std_args, 343 "-passout", "pass:password", "-aes128", 344 "-in", "ec-key-pkcs1.pem", 345 "-out", "ec-key-pkcs1-aes128.pem"]))) 346 # *-key-pkcs8.pem 347 && runall(sub { 348 my $dstfile = shift; 349 (my $srcfile = $dstfile) 350 =~ s/-key-pkcs8\.pem$/-key-pkcs1.pem/i; 351 run(app(["openssl", "pkcs8", @std_args, 352 "-topk8", "-nocrypt", 353 "-in", $srcfile, "-out", $dstfile])); 354 }, grep(/-key-pkcs8\.pem$/, @generated_files)) 355 # *-key-pkcs8-pbes1-sha1-3des.pem 356 && runall(sub { 357 my $dstfile = shift; 358 (my $srcfile = $dstfile) 359 =~ s/-key-pkcs8-pbes1-sha1-3des\.pem$ 360 /-key-pkcs8.pem/ix; 361 run(app(["openssl", "pkcs8", @std_args, 362 "-topk8", 363 "-passout", "pass:password", 364 "-v1", "pbeWithSHA1And3-KeyTripleDES-CBC", 365 "-in", $srcfile, "-out", $dstfile])); 366 }, grep(/-key-pkcs8-pbes1-sha1-3des\.pem$/, @generated_files)) 367 # *-key-pkcs8-pbes1-md5-des.pem 368 && runall(sub { 369 my $dstfile = shift; 370 (my $srcfile = $dstfile) 371 =~ s/-key-pkcs8-pbes1-md5-des\.pem$ 372 /-key-pkcs8.pem/ix; 373 run(app(["openssl", "pkcs8", @std_args, 374 "-topk8", 375 "-passout", "pass:password", 376 "-v1", "pbeWithSHA1And3-KeyTripleDES-CBC", 377 "-in", $srcfile, "-out", $dstfile])); 378 }, grep(/-key-pkcs8-pbes1-md5-des\.pem$/, @generated_files)) 379 # *-key-pkcs8-pbes2-sha1.pem 380 && runall(sub { 381 my $dstfile = shift; 382 (my $srcfile = $dstfile) 383 =~ s/-key-pkcs8-pbes2-sha1\.pem$ 384 /-key-pkcs8.pem/ix; 385 run(app(["openssl", "pkcs8", @std_args, 386 "-topk8", 387 "-passout", "pass:password", 388 "-v2", "aes256", "-v2prf", "hmacWithSHA1", 389 "-in", $srcfile, "-out", $dstfile])); 390 }, grep(/-key-pkcs8-pbes2-sha1\.pem$/, @generated_files)) 391 # *-key-pkcs8-pbes2-sha1.pem 392 && runall(sub { 393 my $dstfile = shift; 394 (my $srcfile = $dstfile) 395 =~ s/-key-pkcs8-pbes2-sha256\.pem$ 396 /-key-pkcs8.pem/ix; 397 run(app(["openssl", "pkcs8", @std_args, 398 "-topk8", 399 "-passout", "pass:password", 400 "-v2", "aes256", "-v2prf", "hmacWithSHA256", 401 "-in", $srcfile, "-out", $dstfile])); 402 }, grep(/-key-pkcs8-pbes2-sha256\.pem$/, @generated_files)) 403 # *-cert.pem (intermediary for the .p12 inits) 404 && run(app(["openssl", "req", "-x509", @std_args, 405 "-config", $cnf, "-noenc", 406 "-key", $cakey, "-out", "cacert.pem"])) 407 && runall(sub { 408 my $srckey = shift; 409 (my $dstfile = $srckey) =~ s|-key-pkcs8\.|-cert.|; 410 (my $csr = $dstfile) =~ s|\.pem|.csr|; 411 412 (run(app(["openssl", "req", "-new", @std_args, 413 "-config", $cnf, "-section", "userreq", 414 "-key", $srckey, "-out", $csr])) 415 && 416 run(app(["openssl", "x509", @std_args, 417 "-days", "3650", 418 "-CA", "cacert.pem", 419 "-CAkey", $cakey, 420 "-set_serial", time(), "-req", 421 "-in", $csr, "-out", $dstfile]))); 422 }, grep(/-key-pkcs8\.pem$/, @generated_files)) 423 # *.p12 424 && runall(sub { 425 my $dstfile = shift; 426 my ($type, $certpbe_index, $keypbe_index, 427 $macalg_index) = 428 $dstfile =~ m{^(.*)-key-(?| 429 # cert and key PBE are same 430 () # 431 ([^-]*-[^-]*)- # key & cert PBE 432 ([^-]*) # MACalg 433 | 434 # cert and key PBE are not same 435 ([^-]*-[^-]*)- # cert PBE 436 ([^-]*-[^-]*)- # key PBE 437 ([^-]*) # MACalg 438 )\.}x; 439 if (!$certpbe_index) { 440 $certpbe_index = $keypbe_index; 441 } 442 my $srckey = "$type-key-pkcs8.pem"; 443 my $srccert = "$type-cert.pem"; 444 my %pbes = 445 ( 446 "sha1-3des" => "pbeWithSHA1And3-KeyTripleDES-CBC", 447 "md5-des" => "pbeWithMD5AndDES-CBC", 448 "aes256-cbc" => "AES-256-CBC", 449 ); 450 my %macalgs = 451 ( 452 "sha1" => "SHA1", 453 "sha256" => "SHA256", 454 ); 455 my $certpbe = $pbes{$certpbe_index}; 456 my $keypbe = $pbes{$keypbe_index}; 457 my $macalg = $macalgs{$macalg_index}; 458 if (!defined($certpbe) || !defined($keypbe) 459 || !defined($macalg)) { 460 print STDERR "Cert PBE for $certpbe_index not defined\n" 461 unless defined $certpbe; 462 print STDERR "Key PBE for $keypbe_index not defined\n" 463 unless defined $keypbe; 464 print STDERR "MACALG for $macalg_index not defined\n" 465 unless defined $macalg; 466 print STDERR "(destination file was $dstfile)\n"; 467 return 0; 468 } 469 run(app(["openssl", "pkcs12", @std_args, 470 "-inkey", $srckey, 471 "-in", $srccert, "-passout", "pass:password", 472 "-chain", "-CAfile", "cacert.pem", 473 "-export", "-macalg", $macalg, 474 "-certpbe", $certpbe, "-keypbe", $keypbe, 475 "-out", $dstfile])); 476 }, grep(/\.p12/, @generated_files)) 477 # *.der (the end all init) 478 && runall(sub { 479 my $dstfile = shift; 480 (my $srcfile = $dstfile) =~ s/\.der$/.pem/i; 481 if (! -f $srcfile) { 482 $srcfile = srctop_file("test", $srcfile); 483 } 484 my $infh; 485 unless (open $infh, $srcfile) { 486 return 0; 487 } 488 my $l; 489 while (($l = <$infh>) !~ /^-----BEGIN\s/ 490 || $l =~ /^-----BEGIN.*PARAMETERS-----/) { 491 } 492 my $b64 = ""; 493 while (($l = <$infh>) !~ /^-----END\s/) { 494 $l =~ s|\R$||; 495 $b64 .= $l unless $l =~ /:/; 496 } 497 close $infh; 498 my $der = decode_base64($b64); 499 unless (length($b64) / 4 * 3 - length($der) < 3) { 500 print STDERR "Length error, ",length($b64), 501 " bytes of base64 became ",length($der), 502 " bytes of der? ($srcfile => $dstfile)\n"; 503 return 0; 504 } 505 my $outfh; 506 unless (open $outfh, ">:raw", $dstfile) { 507 return 0; 508 } 509 print $outfh $der; 510 close $outfh; 511 return 1; 512 }, grep(/\.der$/, @generated_files)) 513 && runall(sub { 514 my $srcfile = shift; 515 my $dstfile = $generated_file_files{$srcfile}; 516 517 unless (copy srctop_file($srcfile), $dstfile) { 518 warn "$!\n"; 519 return 0; 520 } 521 return 1; 522 }, keys %generated_file_files) 523 ); 524} 525 526sub init_rehash { 527 return ( 528 mkdir(catdir(curdir(), 'rehash')) 529 && copy(srctop_file('test', 'testx509.pem'), 530 catdir(curdir(), 'rehash')) 531 && copy(srctop_file('test', 'testcrl.pem'), 532 catdir(curdir(), 'rehash')) 533 && run(app(['openssl', 'rehash', catdir(curdir(), 'rehash')])) 534 ); 535} 536 537sub runall { 538 my ($function, @items) = @_; 539 540 foreach (@items) { 541 return 0 unless $function->($_); 542 } 543 return 1; 544} 545 546# According to RFC8089, a relative file: path is invalid. We still produce 547# them for testing purposes. 548sub to_file_uri { 549 my ($file, $isdir, $authority) = @_; 550 my $vol; 551 my $dir; 552 553 die "to_file_uri: No file given\n" if !defined($file) || $file eq ''; 554 555 ($vol, $dir, $file) = File::Spec->splitpath($file, $isdir // 0); 556 557 # Make sure we have a Unix style directory. 558 $dir = join('/', File::Spec->splitdir($dir)); 559 # Canonicalise it (note: it seems to be only needed on Unix) 560 while (1) { 561 my $newdir = $dir; 562 $newdir =~ s|/[^/]*[^/\.]+[^/]*/\.\./|/|g; 563 last if $newdir eq $dir; 564 $dir = $newdir; 565 } 566 # Take care of the corner cases the loop can't handle, and that $dir 567 # ends with a / unless it's empty 568 $dir =~ s|/[^/]*[^/\.]+[^/]*/\.\.$|/|; 569 $dir =~ s|^[^/]*[^/\.]+[^/]*/\.\./|/|; 570 $dir =~ s|^[^/]*[^/\.]+[^/]*/\.\.$||; 571 if ($isdir // 0) { 572 $dir =~ s|/$|| if $dir ne '/'; 573 } else { 574 $dir .= '/' if $dir ne '' && $dir !~ m|/$|; 575 } 576 577 # If the file system has separate volumes (at present, Windows and VMS) 578 # we need to handle them. In URIs, they are invariably the first 579 # component of the path, which is always absolute. 580 # On VMS, user:[foo.bar] translates to /user/foo/bar 581 # On Windows, c:\Users\Foo translates to /c:/Users/Foo 582 if ($vol ne '') { 583 $vol =~ s|:||g if ($^O eq "VMS"); 584 $dir = '/' . $dir if $dir ne '' && $dir !~ m|^/|; 585 $dir = '/' . $vol . $dir; 586 } 587 $file = $dir . $file; 588 589 return "file://$authority$file" if defined $authority; 590 return "file:$file"; 591} 592 593sub to_abs_file { 594 my ($file) = @_; 595 596 return File::Spec->rel2abs($file); 597} 598 599sub to_abs_file_uri { 600 my ($file, $isdir, $authority) = @_; 601 602 die "to_abs_file_uri: No file given\n" if !defined($file) || $file eq ''; 603 return to_file_uri(to_abs_file($file), $isdir, $authority); 604} 605