scripts/t/Dpkg_Path.t

   1 #!/usr/bin/perl
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  15
  16 use strict;
  17 use warnings;
  18
  19 use Test::More tests => 34;
  20 use Test::Dpkg qw(:paths);
  21
  22 use Cwd qw(realpath);
  23 use File::Path qw(make_path rmtree);
  24 use File::Spec::Functions qw(abs2rel);
  25
  26 use Dpkg::File;
  27
  28 use_ok('Dpkg::Path', 'canonpath', 'resolve_symlink',
  29        'check_files_are_the_same',
  30        'check_directory_traversal',
  31        'get_pkg_root_dir',
  32        'guess_pkg_root_dir', 'relative_to_pkg_root');
  33
  34 my $tmpdir = test_get_temp_path();
  35
  36 make_path("$tmpdir/a/b/c");
  37 make_path("$tmpdir/a/DEBIAN");
  38 make_path("$tmpdir/debian/a/b/c");
  39 symlink 'a/b/c', "$tmpdir/cbis";
  40 symlink '/this/does/not/exist', "$tmpdir/tmp";
  41 symlink '.', "$tmpdir/here";
  42
  43 is(canonpath("$tmpdir/./a///b/c"), "$tmpdir/a/b/c", 'canonpath basic test');
  44 is(canonpath("$tmpdir/a/b/../../a/b/c"), "$tmpdir/a/b/c", 'canonpath and ..');
  45 is(canonpath("$tmpdir/a/b/c/../../"), "$tmpdir/a", 'canonpath .. at end');
  46 is(canonpath("$tmpdir/cbis/../"), "$tmpdir/cbis/..", 'canonpath .. after symlink');
  47
  48 is(resolve_symlink("$tmpdir/here/cbis"), "$tmpdir/here/a/b/c", 'resolve_symlink');
  49 is(resolve_symlink("$tmpdir/tmp"), '/this/does/not/exist', 'resolve_symlink absolute');
  50 is(resolve_symlink("$tmpdir/here"), $tmpdir, 'resolve_symlink .');
  51
  52 ok(!check_files_are_the_same("$tmpdir/here", $tmpdir), 'Symlink is not the same!');
  53 ok(check_files_are_the_same("$tmpdir/here/a", "$tmpdir/a"), 'Same directory');
  54
  55 sub gen_hier_travbase {
  56     my $basedir = shift;
  57
  58     make_path("$basedir/subdir");
  59     file_touch("$basedir/file");
  60     file_touch("$basedir/subdir/subfile");
  61     symlink 'file', "$basedir/symlink-file";
  62     symlink 'subdir/subfile', "$basedir/symlink-subfile";
  63 }
  64
  65 my $travbase = "$tmpdir/travbase";
  66 my $travbase_out = "$tmpdir/travbase-out";
  67 my %travtype = (
  68     none => {
  69         fail => 0,
  70         gen => sub { },
  71     },
  72     same => {
  73         fail => 0,
  74         chroot => "$tmpdir/travbase-same",
  75         gen => sub {
  76             my $basedir = shift;
  77             symlink '../..', "$basedir/subdir/root";
  78         },
  79     },
  80     dev_null => {
  81         fail => 0,
  82         gen => sub {
  83             my $basedir = shift;
  84             symlink '/dev/null', "$basedir/dev-null";
  85         },
  86     },
  87     dots => {
  88         fail => 0,
  89         gen => sub {
  90             my $basedir = shift;
  91             symlink 'aa..bb..cc', "$basedir/dots";
  92         },
  93     },
  94     rel => {
  95         fail => 1,
  96         gen => sub {
  97             my $basedir = shift;
  98             symlink '../../..', "$basedir/rel";
  99         },
 100     },
 101     abs => {
 102         fail => 1,
 103         gen => sub {
 104             my $basedir = shift;
 105             symlink '/etc', "$basedir/abs";
 106         },
 107     },
 108     loop => {
 109         fail => 1,
 110         gen => sub {
 111             my $basedir = shift;
 112             symlink 'self', "$basedir/self";
 113         },
 114     },
 115     enoent_rel => {
 116         fail => 0,
 117         gen => sub {
 118             my $basedir = shift;
 119             symlink 'not-existent', "$basedir/enoent-rel";
 120         },
 121     },
 122     enoent_abs => {
 123         fail => 1,
 124         gen => sub {
 125             my $basedir = shift;
 126             symlink '/not-existent', "$basedir/enoent-abs";
 127         },
 128     },
 129     enoent_indirect_rel => {
 130         fail => 0,
 131         gen => sub {
 132             my $basedir = shift;
 133             symlink 'not-existent', "$basedir/enoent-rel";
 134             symlink 'enoent-rel', "$basedir/enoent-indirect-rel";
 135         },
 136     },
 137     enoent_indirect_abs => {
 138         fail => 1,
 139         gen => sub {
 140             my $basedir = shift;
 141             symlink '/not-existent', "$basedir/enoent-abs";
 142             symlink realpath("$basedir/enoent-abs"), "$basedir/enoent-indirect-abs";
 143         },
 144     },
 145     base_in_none => {
 146         fail => 0,
 147         gen => sub {
 148             my $basedir = shift;
 149             rename $basedir, "$basedir-real";
 150             symlink 'base_in_none-real', $basedir;
 151         },
 152     },
 153     base_in_rel => {
 154         fail => 1,
 155         gen => sub {
 156             my $basedir = shift;
 157             rename $basedir, "$basedir-real";
 158             symlink 'base_in_rel-real', $basedir;
 159             symlink '../../..', "$basedir/rel";
 160         },
 161     },
 162     base_in_abs => {
 163         fail => 1,
 164         gen => sub {
 165             my $basedir = shift;
 166             rename $basedir, "$basedir-real";
 167             symlink 'base_in_abs-real', $basedir;
 168             symlink '/etc', "$basedir/abs";
 169         },
 170     },
 171     base_out_empty => {
 172         fail => 1,
 173         root => $travbase_out,
 174         gen => sub {
 175             my $basedir = shift;
 176             rmtree($basedir);
 177             make_path($basedir);
 178         },
 179     },
 180     base_out_none => {
 181         fail => 1,
 182         root => $travbase_out,
 183         gen => sub { },
 184     },
 185     base_out_rel => {
 186         fail => 1,
 187         root => $travbase_out,
 188         gen => sub {
 189             my $basedir = shift;
 190             symlink '../../..', "$basedir/rel";
 191         },
 192     },
 193     base_out_abs => {
 194         fail => 1,
 195         root => $travbase_out,
 196         gen => sub {
 197             my $basedir = shift;
 198             symlink '/etc', "$basedir/abs";
 199         },
 200     },
 201 );
 202
 203 foreach my $travtype (sort keys %travtype) {
 204     my $trav = $travtype{$travtype};
 205     my $rootdir = $trav->{chroot} // $trav->{root} // $travbase;
 206     my $hierdir = "$rootdir/$travtype";
 207     my $travdir = "$travbase/$travtype";
 208
 209     gen_hier_travbase($hierdir);
 210     symlink abs2rel($hierdir, $travbase), $travdir if exists $trav->{root};
 211     $trav->{gen}->($hierdir);
 212
 213     my $catch;
 214     eval {
 215         check_directory_traversal($travbase, $travdir);
 216         1;
 217     } or do {
 218         $catch = $@;
 219     };
 220     if ($trav->{fail}) {
 221         ok($catch, "directory traversal type $travtype detected");
 222         note("traversal reason: $catch") if $catch;
 223     } else {
 224         ok(! $catch, "no directory traversal type $travtype");
 225         diag("error from check_directory_traversal => $catch") if $catch;
 226     }
 227 }
 228
 229 is(get_pkg_root_dir("$tmpdir/a/b/c"), "$tmpdir/a", 'get_pkg_root_dir');
 230 is(guess_pkg_root_dir("$tmpdir/a/b/c"), "$tmpdir/a", 'guess_pkg_root_dir');
 231 is(relative_to_pkg_root("$tmpdir/a/b/c"), 'b/c', 'relative_to_pkg_root');
 232
 233 chdir($tmpdir);
 234
 235 is(get_pkg_root_dir('debian/a/b/c'), undef, 'get_pkg_root_dir undef');
 236 is(relative_to_pkg_root('debian/a/b/c'), undef, 'relative_to_pkg_root undef');
 237 is(guess_pkg_root_dir('debian/a/b/c'), 'debian/a', 'guess_pkg_root_dir fallback');