1# ex:ts=8 sw=4: 2# $OpenBSD: UList.pm,v 1.7 2023/07/10 09:29:48 espie Exp $ 3# 4# Copyright (c) 2013 Vadim Zhukov <zhuk@openbsd.org> 5# 6# Permission to use, copy, modify, and distribute this software for any 7# purpose with or without fee is hereby granted, provided that the above 8# copyright notice and this permission notice appear in all copies. 9# 10# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 18use v5.36; 19 20# Hash that preserves order of adding items and avoids duplicates. 21# Also, some additional restrictions are applied to make sure 22# the usage of this list is straightforward. 23 24package LT::UList; 25require Tie::Array; 26 27our @ISA = qw(Tie::Array); 28 29sub _translate_num_key($self, $idx, $offset = 0) 30{ 31 if ($idx < 0) { 32 $idx += @$self; 33 die "invalid index" if $idx < 1; 34 } else { 35 $idx++; 36 } 37 die "invalid index $idx" if $idx - int($offset) >= @$self; 38 return $idx; 39} 40 41 42# Construct new UList and returns reference to the array, 43# not to the tied object itself. 44sub new ($class, @p) 45{ 46 tie(my @a, $class, @p); 47 return \@a; 48} 49 50# Given we have successfully added N directories: 51# self->[0] = { directory => 1 } 52# self->[1 .. N] = directories in the order of addition, represented as 0..N-1 53 54sub TIEARRAY($class, @p) 55{ 56 my $self = bless [ {} ], $class; 57 $self->PUSH(@p); 58 return $self; 59} 60 61# Unfortunately, exists() checks for the value being integer even in the 62# case we have EXISTS() outta there. So if you really need to check the 63# presence of particular item, call the method below on the reference 64# returned by tie() or tied() instead. 65sub exists($self, $key) 66{ 67 return exists $self->[0]{$key}; 68} 69 70sub indexof($self, $key) 71{ 72 return exists($self->[0]{$key}) ? ($self->[0]{$key} - 1) : undef; 73} 74 75sub FETCHSIZE($self) 76{ 77 return scalar(@$self) - 1; 78} 79 80sub STORE($, $, $) 81{ 82 die "overwriting elements is unimplemented"; 83} 84 85sub DELETE($, $) 86{ 87 die "delete is unimplemented"; 88} 89 90 91sub FETCH($self, $key) 92{ 93 return $self->[$self->_translate_num_key($key)]; 94} 95 96sub STORESIZE($self, $newsz) 97{ 98 $newsz += 2; 99 my $sz = @$self; 100 101 if ($newsz > $sz) { 102 # XXX any better way to grow? 103 $self->[$newsz - 1] = undef; 104 } elsif ($newsz < $sz) { 105 $self->POP for $newsz .. $sz - 1; 106 } 107} 108 109sub PUSH($self, @p) 110{ 111 for (@p) { 112 next if exists $self->[0]{$_}; 113 $self->[0]{$_} = @$self; 114 push(@$self, $_); 115 } 116} 117 118sub POP($self) 119{ 120 return undef if @$self < 2; 121 my $key = pop @$self; 122 delete $self->[0]{$key}; 123 return $key; 124} 125 126sub SHIFT($self) 127{ 128 return undef if @$self < 2; 129 my $key = splice(@$self, 1, 1); 130 delete $self->[0]{$key}; 131 return $key; 132} 133 134sub UNSHIFT($self, @p) 135{ 136 $self->SPLICE(0, 0, @p); 137} 138 139sub SPLICE($self, $offset = 0, $length = undef, @p) 140{ 141 $offset = $self->_translate_num_key($offset, 1); 142 my $maxrm = @$self - $offset; 143 144 if (defined $length) { 145 if ($length < 0) { 146 $length = $maxrm - (-$length); 147 $length = 0 if $length < 0; 148 } elsif ($length > $maxrm) { 149 $length = $maxrm; 150 } 151 } else { 152 $length = $maxrm; 153 } 154 155 # trailing elements positions to be renumbered by adding $delta 156 my $delta = -$length; 157 158 # 159 # First, always remove elements; then add one by one. 160 # This way we can be sure to not add duplicates, even if 161 # they exist in added elements, e.g., adding ("-lfoo", "-lfoo"). 162 # 163 164 my @ret = splice(@$self, $offset, $length); 165 for (@ret) { 166 delete $self->[0]{$_}; 167 } 168 169 my $i = 0; 170 my %seen; 171 for (@p) { 172 next if exists $seen{$_}; # skip already added items 173 $seen{$_} = 1; 174 if (exists $self->[0]{$_}) { 175 if ($self->[0]{$_} >= $offset + $length) { 176 # "move" from tail to new position 177 splice(@$self, $self->[0]{$_} - $length + $i, 1); 178 } else { 179 next; 180 } 181 } 182 splice(@$self, $offset + $i, 0, $_); 183 $self->[0]{$_} = $offset + $i; 184 $i++; 185 $delta++; 186 } 187 188 for $i ($offset + scalar(@p) .. @$self - 1) { 189 $self->[0]{$self->[$i]} = $i; 190 } 191 192 return @ret; 193} 194 195 196=head1 test 197package main; 198 199sub compare_ulists($list1, $list2) { 200 return 0 if scalar(@$list1) != scalar(@$list2); 201 for my $i (0 .. scalar(@$list1) - 1) { 202 return 0 if $list1->[$i] ne $list2->[$i]; 203 } 204 return 1; 205} 206 207my $r = ['/path0', '/path1']; 208tie(@$r, 'LT::UList'); 209push(@$r, '/path0'); 210push(@$r, '/path1'); 211push(@$r, '/path2'); 212push(@$r, '/path3'); 213push(@$r, '/path4'); 214push(@$r, '/path3'); 215push(@$r, '/path1'); 216push(@$r, '/path5'); 217 218my @tests = ( 219 # offset, length, args, 220 # expected resulting array 221 222 [ 223 3, 0, [], 224 ['/path0', '/path1', '/path2', '/path3', '/path4', '/path5'] 225 ], 226 227 [ 228 3, 2, [], 229 ['/path0', '/path1', '/path2', '/path5'] 230 ], 231 232 [ 233 0, 3, ['/path0', '/path1', '/path2'], 234 ['/path0', '/path1', '/path2', '/path5'] 235 ], 236 237 [ 238 0, 3, ['/path0', '/path5', '/path5', '/path2'], 239 ['/path0', '/path5', '/path2'] 240 ], 241 242 [ 243 0, 3, [], 244 [] 245 ], 246 247); 248 249for my $t (@tests) { 250 splice(@$r, $t->[0], $t->[1], @{$t->[2]}); 251 if (!compare_ulists($r, $t->[3])) { 252 say "expected: ".join(", ", @{$t->[2]}); 253 say " got: ".join(", ", @$r); 254 exit 1; 255 } 256} 257exit 0; 258=cut 259