]>
Commit | Line | Data |
---|---|---|
936218b8 WB |
1 | #!/usr/bin/perl |
2 | ||
3 | use lib '../../src'; | |
5d5a179c | 4 | use lib '.'; |
936218b8 WB |
5 | use strict; |
6 | use warnings; | |
7 | ||
8 | use Carp; | |
9 | use POSIX; | |
10 | use IO::Handle; | |
ffe0b0e0 | 11 | use Storable qw(dclone); |
89075c35 | 12 | use JSON; # allows simple debug-dumping of variables `print to_json($foo, {pretty => 1}) ."\n"` |
936218b8 WB |
13 | |
14 | use PVE::INotify; | |
15 | ||
16 | # Current config, r() parses a network interface string into this variable | |
17 | our $config; | |
18 | ||
19 | ## | |
20 | ## Temporary files: | |
21 | ## | |
22 | # perl conveniently lets you open a string as filehandle so we allow tests | |
23 | # to temporarily save interface files to virtual files: | |
24 | my %saved_files; | |
25 | ||
26 | # Load a temp-file and return it as a string, if it didn't exist, try loading | |
27 | # a real file. | |
28 | sub load($) { | |
29 | my ($from) = @_; | |
30 | ||
31 | if (my $local = $saved_files{$from}) { | |
32 | return $local; | |
33 | } | |
34 | ||
35 | open my $fh, '<', $from or die "failed to open $from: $!"; | |
36 | local $/ = undef; | |
37 | my $data = <$fh>; | |
38 | close $fh; | |
39 | return $data; | |
40 | } | |
41 | ||
42 | # Save a temporary file. | |
43 | sub save($$) { | |
44 | my ($file, $data) = @_; | |
45 | $saved_files{$file} = $data; | |
46 | } | |
47 | ||
48 | # Delete a temporary file | |
49 | sub delfile($) { | |
50 | my $file = @_; | |
51 | die "no such file: $file" if !delete $saved_files{$file}; | |
52 | } | |
53 | ||
54 | # Delete all temporary files. | |
55 | sub flush_files() { | |
56 | foreach (keys %saved_files) { | |
57 | delete $saved_files{$_} if $_ !~ m,^shared/,; | |
58 | } | |
59 | } | |
60 | ||
61 | ## | |
62 | ## Interface parsing: | |
63 | ## | |
64 | ||
12a235d6 WB |
65 | # Read an interfaces file with optional /proc/net/dev file content string and |
66 | # the list of active interfaces, which otherwise default | |
936218b8 | 67 | sub r($;$$) { |
12a235d6 | 68 | my ($ifaces, $proc_net_dev, $active) = @_; |
936218b8 | 69 | $proc_net_dev //= load('proc_net_dev'); |
12a235d6 | 70 | $active //= [split(/\s+/, load('active_interfaces'))]; |
936218b8 WB |
71 | open my $fh1, '<', \$ifaces; |
72 | open my $fh2, '<', \$proc_net_dev; | |
12a235d6 | 73 | $config = PVE::INotify::__read_etc_network_interfaces($fh1, $fh2, $active); |
936218b8 WB |
74 | close $fh1; |
75 | } | |
76 | ||
77 | # Turn the current network config into a string. | |
78 | sub w() { | |
ffe0b0e0 TL |
79 | # write shouldn't be able to change a previously parsed config |
80 | my $config_clone = dclone($config); | |
e8c1bbfc | 81 | return PVE::INotify::__write_etc_network_interfaces($config_clone, 1); |
936218b8 WB |
82 | } |
83 | ||
84 | ## | |
85 | ## Interface modification helpers | |
86 | ## | |
87 | ||
88 | # Update an interface | |
89 | sub update_iface($$%) { | |
90 | my ($name, $families, %extra) = @_; | |
91 | ||
92 | my $ifaces = $config->{ifaces}; | |
93 | my $if = $ifaces->{$name}; | |
94 | ||
95 | die "no such interface: $name\n" if !$if; | |
96 | ||
97 | $if->{exists} = 1; | |
98 | ||
99 | # merge extra flags (like bridge_ports, ovs_*) directly | |
100 | $if->{$_} = $extra{$_} foreach keys %extra; | |
101 | ||
102 | return if !$families; | |
103 | ||
104 | my $if_families = $if->{families} ||= []; | |
105 | foreach my $family (@$families) { | |
106 | my $type = delete $family->{family}; | |
107 | @$if_families = ((grep { $_ ne $type } @$if_families), $type); | |
108 | ||
109 | (my $suffix = $type) =~ s/^inet//; | |
110 | $if->{"method$suffix"} = $family->{address} ? 'static' : 'manual'; | |
111 | foreach(qw(address netmask gateway options)) { | |
112 | if (my $value = delete $family->{$_}) { | |
113 | $if->{"$_${suffix}"} = $value; | |
114 | } | |
115 | } | |
116 | } | |
117 | } | |
118 | ||
119 | # Create an interface and error if it already exists. | |
120 | sub new_iface($$$%) { | |
121 | my ($name, $type, $families, %extra) = @_; | |
122 | my $ifaces = $config->{ifaces}; | |
123 | croak "interface already exists: $name" if $ifaces->{$name}; | |
124 | $ifaces->{$name} = { type => $type }; | |
125 | update_iface($name, $families, %extra); | |
126 | } | |
127 | ||
128 | # Delete an interface and error if it did not exist. | |
129 | sub delete_iface($;$) { | |
130 | my ($name, $family) = @_; | |
131 | my $ifaces = $config->{ifaces}; | |
132 | my $if = $ifaces->{$name} ||= {}; | |
133 | croak "interface doesn't exist: $name" if !$if; | |
134 | ||
135 | if (!$family) { | |
136 | delete $ifaces->{$name}; | |
137 | return; | |
138 | } | |
139 | ||
140 | my $families = $if->{families}; | |
141 | @$families = grep {$_ ne $family} @$families; | |
142 | (my $suffix = $family) =~ s/^inet//; | |
143 | delete $if->{"$_$suffix"} foreach qw(address netmask gateway options); | |
144 | } | |
145 | ||
146 | ## | |
147 | ## Test helpers: | |
148 | ## | |
149 | ||
150 | # Compare two strings line by line and show a diff/error if they differ. | |
151 | sub diff($$) { | |
152 | my ($a, $b) = @_; | |
153 | return if $a eq $b; | |
154 | ||
155 | my ($ra, $wa) = POSIX::pipe(); | |
156 | my ($rb, $wb) = POSIX::pipe(); | |
157 | my $ha = IO::Handle->new_from_fd($wa, 'w'); | |
158 | my $hb = IO::Handle->new_from_fd($wb, 'w'); | |
159 | ||
160 | open my $diffproc, '-|', 'diff', '-up', "/dev/fd/$ra", "/dev/fd/$rb" | |
161 | or die "failed to run program 'diff': $!"; | |
162 | POSIX::close($ra); | |
163 | POSIX::close($rb); | |
164 | ||
165 | open my $f1, '<', \$a; | |
166 | open my $f2, '<', \$b; | |
167 | my ($line1, $line2); | |
168 | do { | |
169 | $ha->print($line1) if defined($line1 = <$f1>); | |
170 | $hb->print($line2) if defined($line2 = <$f2>); | |
171 | } while (defined($line1 // $line2)); | |
172 | close $f1; | |
173 | close $f2; | |
174 | close $ha; | |
175 | close $hb; | |
176 | ||
177 | local $/ = undef; | |
178 | my $diff = <$diffproc>; | |
179 | close $diffproc; | |
180 | die "files differ:\n$diff"; | |
181 | } | |
182 | ||
183 | # Write the current interface config and compare the result to a string. | |
184 | sub expect($) { | |
185 | my ($expected) = @_; | |
186 | my $got = w(); | |
187 | diff($expected, $got); | |
188 | } | |
189 | ||
190 | ## | |
191 | ## Main test execution: | |
192 | ## | |
193 | # (sorted, it's not used right now but tests could pass on temporary files by | |
194 | # prefixing the name with shared/ and thus you might want to split a larger | |
195 | # test into t.01.first-part.pl, t.02.second-part.pl, etc. | |
196 | my $total = 0; | |
197 | my $failed = 0; | |
198 | for our $Test (sort <t.*.pl>) { | |
199 | $total++; | |
200 | flush_files(); | |
201 | eval { | |
202 | require $Test; | |
203 | }; | |
204 | if ($@) { | |
205 | print "FAIL: $Test\n$@\n\n"; | |
206 | $failed++; | |
207 | } else { | |
208 | print "PASS: $Test\n"; | |
209 | } | |
210 | } | |
211 | ||
212 | die "$failed out of $total tests failed\n" if $failed; |