1#!/usr/bin/perl
2
3#
4# xrandr Test suite
5#
6# Do a set of xrandr calls and verify that the screen setup is as expected
7# after each call.
8#
9
10$xrandr="xrandr";
11$xrandr=$ENV{XRANDR} if defined $ENV{XRANDR};
12$version="0.1";
13$inbetween="";
14print "\n***** xrandr test suite V$version *****\n\n";
15
16# Known issues and their fixes
17%fixes=(
18 s2 => "xrandr: 307f3686",
19 s4 => "xserver: f7dd0c72",
20 s11 => "xrandr: f7aaf894",
21 s18 => "issue known, but not fixed yet"
22);
23
24# Get output configuration
25@outputs=();
26%mode_name=();
27%out_modes=();
28%modes=();
29open P, "$xrandr --verbose|" or die "$xrandr";
30while (<P>) {
31  if (/^\S/) {
32    $o=""; $m=""; $x="";
33  }
34  if (/^(\S+)\s(connected|unknown connection)\s/) {
35    $o=$1;
36    push @outputs, $o         if $2 eq "connected";
37    push @outputs_unknown, $o if $2 eq "unknown connection";
38    $out_modes{$o}=[];
39  } elsif (/^\s+(\d+x\d+)\s+\((0x[0-9a-f]+)\)/) {
40    my $m=$1;
41    my $x=$2;
42    while (<P>) {
43      if (/^\s+(\d+x\d+)\s+\((0x[0-9a-f]+)\)/) {
44        print "WARNING: Ignoring incomplete mode $x:$m on $o\n";
45        $m=$1, $x=$2;
46      } elsif (/^\s+v:.*?([0-9.]+)Hz\s*$/) {
47        if (defined $mode_name{$x} && $mode_name{$x} ne "$m\@$1") {
48	  print "WARNING: Ignoring mode $x:$m\@$1 because $x:$mode_name{$x} already exists\n";
49	  last;
50	}
51	if (defined $modes{"$o:$x"}) {
52	  print "WARNING: Ignoring duplicate mode $x on $o\n";
53	  last;
54	}
55	$mode_name{$x}="$m\@$1";
56	push @{$out_modes{$o}}, $x;
57	$modes{"$o:$x"}=$x;
58	$modes{"$o:$m\@$1"}=$x;
59	$modes{"$o:$m"}=$x;
60        last;
61      }
62    }
63  }
64}
65close P;
66@outputs=(@outputs,@outputs_unknown) if @outputs < 2;
67
68# preamble
69if ($ARGV[0] eq "-w") {
70  print "Waiting for keypress after each test for manual verification.\n\n";
71  $inbetween='print "    Press <Return> to continue...\n"; $_=<STDIN>';
72} elsif ($ARGV[0] ne "") {
73  print "Preparing for test # $ARGV[0]\n\n";
74  $prepare = $ARGV[0];
75}
76
77print "Detected connected outputs and available modes:\n\n";
78for $o (@outputs) {
79  print "$o:";
80  my $i=0;
81  for $x (@{$out_modes{$o}}) {
82    print "\n" if $i++ % 3 == 0;
83    print "  $x:$mode_name{$x}";
84  }
85  print "\n";
86}
87print "\n";
88
89if (@outputs < 2) {
90  print "Found less than two connected outputs. No tests available for that.\n";
91  exit 1;
92}
93if (@outputs > 2) {
94  print "Note: No tests for more than two connected outputs available yet.\n";
95  print "Using the first two outputs.\n\n";
96}
97
98$a=$outputs[0];
99$b=$outputs[1];
100
101# For each resolution only a single refresh rate should be used in order to
102# reduce ambiguities. For that we need to find unused modes. The %used hash is
103# used to track used ones. All references point to <id>.
104#   <output>:<id>
105#   <output>:<width>x<height>@<refresh>
106#   <output>:<width>x<height>
107#   <id>
108#   <width>x<height>@<refresh>
109#   <width>x<height>
110%used=();
111
112# Find biggest common mode
113undef $sab;
114for my $x (@{$out_modes{$a}}) {
115  if (defined $modes{"$b:$x"}) {
116    $m=$mode_name{$x};
117    $sab="$x:$m";
118    $m =~ m/(\d+x\d+)\@([0-9.]+)/;
119    $used{$x} = $x;
120    $used{$1} = $x;
121    $used{"$a:$x"} = $x;
122    $used{"$b:$x"} = $x;
123    $used{"$a:$m"} = $mode_name{$x};
124    $used{"$b:$m"} = $mode_name{$x};
125    $used{"$a:$1"} = $x;
126    $used{"$b:$1"} = $x;
127    last;
128  }
129}
130if (! defined $sab) {
131  print "Cannot find common mode between $a and $b.\n";
132  print "Test suite is designed to need a common mode.\n";
133  exit 1;
134}
135
136# Find sets of additional non-common modes
137# Try to get non-overlapping resolution set, but if that fails get overlapping
138# ones but with different refresh values, if that fails any with nonequal
139# timings, and if that fails any one, but warn.
140# Try modes unknown to other outputs first, they might need common ones
141# themselves.
142sub get_mode {
143  my $o=$_[0];
144  for my $pass (1, 2, 3, 4, 5, 6, 7, 8, 9) {
145    CONT: for my $x (@{$out_modes{$o}}) {
146      $m = $mode_name{$x};
147      $m =~ m/(\d+x\d+)\@([0-9.]+)/;
148      next CONT if defined $used{"$o:$x"};
149      next CONT if $pass < 9 && defined $used{"$o:$m"};
150      next CONT if $pass < 7 && defined $used{"$o:$1"};
151      next CONT if $pass < 6 && defined $used{$m};
152      next CONT if $pass < 4 && defined $used{$1};
153      for my $other (@outputs) {
154        next if $other eq $o;
155        next CONT if $pass < 8 && defined $used{"$o:$x"};
156        next CONT if $pass < 5 && $used{"$other:$1"};
157	next CONT if $pass < 3 && $modes{"$other:$m"};
158	next CONT if $pass < 2 && $modes{"$other:$1"};
159      }
160      if ($pass >= 6) {
161        print "Warning: No more non-common modes, using $m for $o\n";
162      }
163      $used{"$o:$x"} = $x;
164      $used{"$o:$m"} = $x;
165      $used{"$o:$1"} = $x;
166      $used{$x} = $x;
167      $used{$m} = $x;
168      $used{$1} = $x;
169      return "$x:$m";
170    }
171  }
172  print "Warning: Cannot find any more modes for $o.\n";
173  return undef;
174}
175sub mode_to_randr {
176  $_[0] =~ m/^(0x[0-9a-f]+):(\d+)x(\d+)\@([0-9.]+)/;
177  return "--mode $1";
178}
179
180$sa1=get_mode($a);
181$sa2=get_mode($a);
182$sb1=get_mode($b);
183$sb2=get_mode($b);
184
185$mab=mode_to_randr($sab);
186$ma1=mode_to_randr($sa1);
187$ma2=mode_to_randr($sa2);
188$mb1=mode_to_randr($sb1);
189$mb2=mode_to_randr($sb2);
190
191# Shortcuts
192$oa="--output $a";
193$ob="--output $b";
194
195# Print config
196print "A:  $a (mab,ma1,ma2)\nB:  $b (mab,mb1,mb2)\n\n";
197print "mab: $sab\nma1: $sa1\nma2: $sa2\nmb1: $sb1\nmb2: $sb2\n\n";
198print "Initial config:\n";
199system "$xrandr";
200print "\n";
201
202# Test subroutine
203sub t {
204  my $name=$_[0];
205  my $expect=$_[1];
206  my $args=$_[2];
207  print "*** $name:  $args\n";
208  print "?   $expect\n" if $expect ne "";
209  if ($name eq $prepare) {
210    print "->  Prepared to run test\n\nRun test now with\n$xrandr --verbose $args\n\n";
211    exit 0;
212  }
213  my %r   = ();
214  my $r   = "";
215  my $out = "";
216  if (system ("$xrandr --verbose $args") == 0) {
217    # Determine active configuration
218    open P, "$xrandr --verbose|" or die "$xrandr";
219    my ($o, $c, $m, $x);
220    while (<P>) {
221      $out.=$_;
222      if (/^\S/) {
223        $o=""; $c=""; $m=""; $x="";
224      }
225      if (/^(\S+)\s(connected|unknown connection) (\d+x\d+)\+\d+\+\d+\s+\((0x[0-9a-f]+)\)/) {
226        $o=$1;
227	$m=$3;
228	$x=$4;
229	$o="A" if $o eq $a;
230	$o="B" if $o eq $b;
231      } elsif (/^\s*CRTC:\s*(\d)/) {
232        $c=$1;
233      } elsif (/^\s+$m\s+\($x\)/) {
234        while (<P>) {
235	  $out.=$_;
236          if (/^\s+\d+x\d+\s/) {
237	    $r{$o}="$x:$m\@?($c)" unless defined $r{$o};
238	    # we don't have to reparse this - something is wrong anyway,
239	    # and it probably is no relevant resolution as well
240	    last;
241	  } elsif (/^\s+v:.*?([0-9.]+)Hz\s*$/) {
242            $r{$o}="$x:$m\@$1($c)";
243	    last;
244	  }
245	}
246      }
247    }
248    for $o (sort keys %r) {
249      $r .= "  $o: $r{$o}";
250    }
251    close P;
252  } else {
253    $expect="success" if $expect="";
254    $r="failed";
255  }
256  # Verify
257  if ($expect ne "") {
258    print "->$r\n";
259    if ($r eq "  $expect") {
260      print "->  ok\n\n";
261    } else {
262      print "\n$out";
263      print "\n->  FAILED: Test # $name:\n\n";
264      print "    $xrandr --verbose $args\n\n";
265      if ($fixes{$name}) {
266        print "\nThere are known issues with some packages regarding this test.\n";
267	print "Please verify that you have at least the following git versions\n";
268	print "before reporting a bug to xorg-devel:\n\n";
269	print "    $fixes{$name}\n\n";
270      }
271      exit 1;
272    }
273    eval $inbetween;
274  } else {
275    print "->  ignored\n\n";
276  }
277}
278
279
280# Test cases
281#
282# The tests are carefully designed to test certain transitions between
283# RandR states that can only be reached by certain calling sequences.
284# So be careful with altering them. For additional tests, better add them
285# to the end of already existing tests of one part.
286
287# Part 1: Single output switching tests (except for trivial explicit --crtc)
288t ("p",   "",                        "$oa --off $ob --off");
289t ("s1",  "A: $sa1(0)",              "$oa $ma1 --crtc 0");
290t ("s2",  "A: $sa1(0)  B: $sab(1)",  "$ob $mab");
291# TODO: should be A: $sab(1) someday (auto re-cloning)"
292#t ("s3",  "A: $sab(1)  B: $sab(1)",  "$oa $mab");
293t ("s3",  "A: $sab(0)  B: $sab(1)",  "$oa $mab --crtc 0");
294t ("p4",  "A: $sab(1)  B: $sab(1)",  "$oa $mab --crtc 1 $ob --crtc 1");
295t ("s4",  "A: $sa2(0)  B: $sab(1)",  "$oa $ma2");
296t ("s5",  "A: $sa1(0)  B: $sab(1)",  "$oa $ma1");
297t ("s6",  "A: $sa1(0)  B: $sb1(1)",  "$ob $mb1");
298t ("s7",  "A: $sab(0)  B: $sb1(1)",  "$oa $mab");
299t ("s8",  "A: $sab(0)  B: $sb2(1)",  "$ob $mb2");
300t ("s9",  "A: $sab(0)  B: $sb1(1)",  "$ob $mb1");
301# TODO: should be B: $sab(0) someday (auto re-cloning)"
302#t ("s10", "A: $sab(0)  B: $sab(0)",  "$ob $mab");
303t ("p11", "A: $sab(0)  B: $sab(0)",  "$oa --crtc 0 $ob $mab --crtc 0");
304t ("s11", "A: $sa1(1)  B: $sab(0)",  "$oa $ma1");
305t ("s12", "A: $sa1(1)  B: $sb1(0)",  "$ob $mb1");
306t ("s13", "A: $sa1(1)  B: $sab(0)",  "$ob $mab");
307t ("s14", "A: $sa2(1)  B: $sab(0)",  "$oa $ma2");
308t ("s15", "A: $sa1(1)  B: $sab(0)",  "$oa $ma1");
309t ("p16", "A: $sab(0)  B: $sab(0)",  "$oa $mab --crtc 0 $ob --crtc 0");
310t ("s16", "A: $sab(1)  B: $sab(0)",  "$oa --pos 10x0");
311t ("p17", "A: $sab(0)  B: $sab(0)",  "$oa --crtc 0 $ob --crtc 0");
312t ("s17", "A: $sab(0)  B: $sab(1)",  "$ob --pos 10x0");
313t ("p18", "A: $sab(0)  B: $sab(0)",  "$oa --crtc 0 $ob --crtc 0");
314# TODO: s18-s19 are known to fail
315t ("s18", "A: $sab(1)  B: $sab(0)",  "$oa --crtc 1");
316t ("p19", "A: $sab(1)  B: $sab(1)",  "$oa --crtc 1 $ob --crtc 1");
317t ("s19", "A: $sab(0)  B: $sab(1)",  "$oa --pos 10x0");
318
319# Part 2: Complex dual output switching tests
320# TODO: d1 is known to fail
321t ("pd1", "A: $sab(0)",              "$oa --crtc 0 $ob --off");
322t ("d1",  "B: $sab(0)",              "$oa --off $ob $mab");
323
324# Done
325
326print "All tests succeeded.\n";
327
328exit 0;
329
330