test/recipes/90-test_store.t

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