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