8c5a532d2e82398ecd3e8e5a812ed8c282afc9e8
[linux-gpio-pinout] / gpio.pl
1 #!/usr/bin/perl
2 use warnings;
3 use strict;
4 use autodie;
5 use Data::Dump qw(dump);
6 use Getopt::Long;
7
8 my $opt_svg = 0;
9 my $opt_alt = 0;
10 my $opt_invert = 0;
11 my $opt_vertical = 0;
12 my $opt_horizontal = 0;
13 my $opt_edge = 0;
14 my $opt_middle = 0;
15 my $opt_zebra = 0;
16 my $opt_lines = 0;
17 my $opt_read = '';
18 my $opt_pins = '';
19 my $opt_color = 0;
20 my $opt_pinmux = 0;
21 GetOptions(
22         'svg!' => \$opt_svg,
23         'alt!' => \$opt_alt,
24         'invert!' => \$opt_invert,
25         'vertical-flip!' => \$opt_vertical,
26         'horizontal-flip!' => \$opt_horizontal,
27         'edge-pins!' => \$opt_edge,
28         'middle-pins!' => \$opt_middle,
29         'zebra!' => \$opt_zebra,
30         'lines!' => \$opt_lines,
31         'read=s' => \$opt_read,
32         'pins=s' => \$opt_pins,
33         'color' => \$opt_color,
34         'pinmux' => \$opt_pinmux,
35 );
36
37 # svg font hints
38 my $font_w = 1.67; # < 2.54, font is not perfect square
39 my $font_b = 2.10; # font baseline position
40
41 $opt_read .= '/' unless $opt_read =~ m/\/$/;
42
43 sub slurp {
44         open(my $fh, '<', $opt_read . shift);
45         local $/ = undef;
46         <$fh>;
47 }
48
49 my $pins;
50
51 my $model = slurp('/proc/device-tree/model');
52 $model =~ s/\x00$//; # strip kernel NULL
53 warn "# model [$model]";
54
55 OPEN_PINS_AGAIN:
56 open(DATA, '<', $opt_pins) if $opt_pins;
57
58 my @lines;
59 my $line_i = 0;
60
61 my $include = 0;
62 while(<DATA>) {
63         chomp;
64         if ( m/^#\s(.+)/ ) {
65                 warn "MODEL [$1] == [$model] ?\n";
66                 if ( $model =~ m/$1/ ) {
67                         $include = 1;
68                 } else {
69                         $include = 0;
70                 }
71         } elsif ( $include || $opt_pins ) {
72                 push @{ $pins->{$1} }, $line_i while ( m/\t\s*(\w+\d+)/g );
73
74                 push @lines, $_;
75
76                 $line_i++;
77         } else {
78                 warn "IGNORE: [$_]\n";
79         }
80 }
81
82 if ( ! $opt_pins && ! $pins ) {
83         my $glob = $model;
84         $glob =~ s/^(\w+).*$/$1/;
85         my @pins = glob "pins/${glob}*";
86         die "pins/${glob} NOT FOUND for this board, please create one and contribute" unless @pins;
87         warn "# possible pins: ",dump( \@pins );
88         $opt_pins = $pins[0];
89         goto OPEN_PINS_AGAIN;
90 }
91
92 die "add pin definition for # $model" unless $pins;
93
94 #warn "# lines ",dump( \@lines );
95 warn "# pins ",dump($pins);
96
97 my $serial_tty;
98 foreach (
99         glob($opt_read . '/sys/devices/platform/soc*/*.serial/tty/tty*'),       # 4.x
100         glob(            '/sys/devices/soc.*/*.uart/tty/tty*')                  # 3.10
101 ) {
102         my @v = split(/\//, $_);
103         $serial_tty->{ $v[-3] } = $v[-1];
104 }
105 warn "# serial_tty = ",dump($serial_tty);
106
107
108 my $pin_function;
109 my $device;
110 my $pin;
111 my $function;
112
113 sub annotate_pin {
114         my ($pin, $note) = @_;
115         if ( $pins->{$pin} ) {
116                 foreach my $line ( @{$pins->{$pin}} ) {
117                         my $t = $lines[$line];
118                         if ( $opt_svg ) {
119                                 $t =~ s/$pin/$note/;
120                         } else {
121                                 $t =~ s/$pin/$pin $note/ || warn "can't find $pin in [$t]";
122                         }
123                         $lines[$line] = $t;
124                         warn "# $line: $lines[$line]\n";
125                 }
126         } else {
127                 warn "IGNORED: pin $pin function $note\n";
128         }
129 }
130
131 open(my $fh, '<', $opt_read . '/sys/kernel/debug/pinctrl/pinctrl-maps');
132 while(<$fh>) {
133         chomp;
134         if ( m/^device (\S+)/ ) {
135                 $device = $1;
136                 if ( my $replace = $serial_tty->{$device} ) {
137                         $device = $replace; # replace serial hex with kernel name
138                 } else {
139                         $device =~ s/^[0-9a-f]*\.//; # remove hex address
140                 }
141         } elsif ( m/^group (\w+\d+)/ ) {
142                 $pin = $1;
143
144         } elsif ( m/^function (\S+)/ ) {
145                 $function = $1;
146         } elsif ( m/^$/ ) {
147                 if ( $device && $pin && $function ) {
148                         push @{ $pin_function->{$pin} }, "$device $function";
149
150                         annotate_pin $pin, "[$device $function]";
151                 } else {
152                         warn "missing one of ",dump( $device, $pin, $function );
153                 }
154
155                 $device = undef;
156                 $pin = undef;
157                 $function = undef;
158
159         }
160 }
161
162 warn "# pin_function = ",dump($pin_function);
163
164
165 # insert kernel gpio info
166 my $linux_gpio_name;
167 open(my $pins_fh, '<', (glob "/sys/kernel/debug/pinctrl/*/pins")[0]);
168 while(<$pins_fh>) {
169         if ( m/^pin (\d+) \(([^\)]+)\)/ ) {
170                 $linux_gpio_name->{$1} = $2;
171         }
172 }
173 warn "# linux_gpio_name = ",dump( $linux_gpio_name );
174
175
176 my $gpio_debug;
177 open(my $gpio_fh, '<', '/sys/kernel/debug/gpio');
178 while(<$gpio_fh>) {
179         if (m/|/ ) {
180                 s/^\s+//;
181                 s/\s+$//;
182                 my @l = split(/\s*[\(\|\)]\s*/, $_);
183                 warn "XXX ", dump( \@l );
184                 if ( $l[0] =~ m/gpio-(\d+)/ ) {
185                         if ( my $pin = $linux_gpio_name->{$1} ) {
186                                 $gpio_debug->{ $pin } = $l[2];
187                                 $l[3] =~ s/\s\s+/ /g;
188                                 annotate_pin $pin, qq{"$l[2]" $l[3]};
189                         } else {
190                                 warn "FIXME can't find $1 in ",dump( $linux_gpio_name );
191                         }
192                 }
193         }
194
195 }
196 warn "# gpio_debug = ",dump( $gpio_debug );
197
198
199
200 my $have_sunxi_pio = `which sunxi-pio`;
201 if ( $have_sunxi_pio ) {
202
203 open(my $pio, '-|', 'sunxi-pio -m print');
204 while(<$pio>) {
205         chomp;
206         s/[<>]+/ /g;
207         my @p = split(/\s+/,$_);
208         warn "# pio ",dump(\@p);
209         # annotate input 0 and output 1 pins
210 #       annotate_pin $p[0], ( $p[1] ? 'O' : 'I' ) . ':' . $p[4] if $p[1] == 0 || $p[1] == 1;
211         my $pin = shift @p;
212         annotate_pin $pin, join(' ',@p) if ! $opt_svg;
213 }
214 close($pio);
215
216 } # have_sunxi_pio
217
218 my $have_raspi_gpio = `which raspi-gpio`;
219 if ( $have_raspi_gpio ) {
220
221 my @gpio_pins;
222
223 open(my $pio, '-|', 'raspi-gpio get');
224 while(<$pio>) {
225         chomp;
226         if ( m/^\s*GPIO (\d+): (.+)/ ) {
227                 my $pin = 'gpio' . $1;
228                 push @gpio_pins, $1;
229                 annotate_pin $pin, $2 if ! $opt_svg;
230         }
231 }
232 close($pio);
233
234 open(my $pio, '-|', 'raspi-gpio funcs '.join(',',@gpio_pins));
235 while(<$pio>) {
236         chomp;
237         s/,\s/ /g;
238         if (m/^(\d+)\s+(.*)/) {
239                 annotate_pin 'gpio'.$1,"($2)" if $opt_alt;
240         }
241 }
242 close($pio);
243
244 } # have_raspi_gpio
245
246
247 my $pinmux;
248 my $pinmux_path = (glob("/sys/kernel/debug/pinctrl/*/pinmux-functions"))[0];
249 if ( $opt_pinmux && -e $pinmux_path ) {
250         open(my $mux, '<', $pinmux_path);
251         while(<$mux>) {
252                 chomp;
253                 if ( m/function: (\w+), groups = \[ (.*) \]/ ) {
254                         my ( $func, $pins ) = ( $1, $2 );
255                         foreach ( split(/\s+/,$pins) ) {
256                                 push @{ $pinmux->{$_} }, $func;
257                         }
258                 } else {
259                         warn "IGNORED [$pinmux_path] [$_]\n";
260                 }
261         }
262
263         foreach my $pin ( keys %$pinmux ) {
264                 if ( exists $pins->{$pin} ) {
265                         annotate_pin $pin, '{' . join(' ', @{$pinmux->{$pin}}) . '}';
266                 } else {
267                         warn "IGNORED mux on $pin\n";
268                 }
269         }
270
271         warn "# pinmux = ",dump( $pinmux );
272 }
273
274
275
276 my @max_len = ( 0,0,0,0 );
277 my @line_parts;
278
279 shift(@lines) while ( ! $lines[0] );    # remove empty at beginning
280 pop(@lines) while ( ! $lines[-1] );     # remove empty at end
281
282 foreach my $line (@lines) {
283         if ( $line =~ m/^#/ ) {
284                 push @line_parts, [ $line ] unless $opt_svg && $line =~ m/^###+/; # SVG doesn't display 3rd level comments
285                 next;
286         }
287         $line =~ s/\[(\w+)\s+(\w+)\] \[\1\s+(\w+)\]/[$1 $2 $3]/g; # compress kernel annotation with same prefix
288         $line =~ s/(\[(?:uart\d*|serial|tty\w+))([^\t]*\]\s[^\t]*(rx|tx)d?)/$1 $3$2/gi;
289         $line =~ s/(\[i2c)([^\t]*\]\s[^\t]*(scl?k?|sda))/$1 $3$2/gi;
290         $line =~ s/(\[spi)([^\t]*\]\s[^\t]*(miso|mosi|s?clk|c[se]\d*))/$1 $3$2/gi;
291         $line =~ s/\s*\([^\)]+\)//g if ! $opt_alt;
292
293         # shorten duplicate kernel device/function
294         $line =~ s/\[serial (\w+) (uart\d+)\]/[$2 $1]/g;
295         $line =~ s/\[(\w+) (\w+) \1(\d+)\]/[$1$3 $2]/g;
296
297         $line =~ s/\[(\w+)\s+([^\]]+)\s+\1\]/[$1 $2]/g; # duplicate
298
299         my @v = split(/\s*\t+\s*/,$line,4);
300         @v = ( $v[2], $v[3], $v[0], $v[1] ) if $opt_horizontal && $v[2];
301
302         push @line_parts, [ @v ];
303         foreach my $i ( 0 .. 3 ) {
304                 next unless exists $v[$i];
305                 next if $v[$i] =~ m/^#/; # don't calculate comments into max length
306                 my $l = length($v[$i]);
307                 $max_len[$i] = $l if $l > $max_len[$i];
308         }
309 }
310
311 warn "# max_len = ",dump( \@max_len );
312 warn "# line_parts = ",dump( \@line_parts );
313
314 #print "$_\n" foreach @lines;
315
316 my $x = 20.00; # mm
317 my $y = 20.00; # mm
318
319 if ( $opt_svg ) {
320         print qq{<?xml version="1.0" encoding="UTF-8" standalone="no"?>
321 <svg
322    xmlns:dc="http://purl.org/dc/elements/1.1/"
323    xmlns:cc="http://creativecommons.org/ns#"
324    xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
325    xmlns:svg="http://www.w3.org/2000/svg"
326    xmlns="http://www.w3.org/2000/svg"
327    xmlns:xlink="http://www.w3.org/1999/xlink"
328    id="svg8"
329    version="1.1"
330    viewBox="0 0 210 297"
331    height="297mm"
332    width="210mm">
333
334
335 <g id="layer1">
336
337         }; # svg, insert rest of rect
338
339         print qq{<rect x="0" y="0" width="210" height="297" style="fill:#000000" id="high-contrast"/>} if $opt_invert;
340 }
341
342 my @later;
343
344 my $cols = {    # foreground background
345         txt  => [ '#000000', '#ffffff' ],
346         pins => [ '#ffffff', '#ff00ff' ],
347         vcc  => [ '#ff0000', '#ffff00' ],
348         gnd  => [ '#000000', '#00ffff' ],
349         i2c  => [ '#008800', '#ffcccc' ],
350         serial=>[ '#000088', '#ccffcc' ],
351         spi  => [ '#880000', '#ccccff' ],
352 };
353
354 sub swap_cols {
355         my $swap = shift;
356         die "$swap not found in ",dump($cols) unless $cols->{$swap};
357         my ( $c1, $c2 ) = @{ $cols->{$swap} };
358         $cols->{$swap} = [ $c2, $c1 ];
359 }
360
361 swap_cols 'txt' if $opt_invert;
362         
363
364 sub svg_style {
365         my ($name,$x,$y,$col) = @_;
366
367         return '' unless $opt_color;
368
369         $y -= $font_b; # shift box overlay to right vertical position based on font baseline
370
371         sub rect {
372                 my ($x,$y,$col,$fill) = @_;
373                 print qq{<rect x="$x" y="$y" height="2.54" width="}, $max_len[$col] * $font_w, qq{" style="fill:$fill;stroke:#ffffff;stroke-width:0.10" />\n};
374
375         }
376
377         if ( $name =~ m/^(\d+)$/ ) { # pins
378                 my $pin = $1;
379                 my ( $fg, $bg ) = @{ $cols->{pins} };
380                 if ( $pin == 1 ) {
381                         my $w  = $max_len[$col]*$font_w - 0.1;
382                         my $cx = $x + $w;
383                         my $cy = $y + 2.54;
384                         #print qq{<polygon points="$x,$y $cx,$y $x,$cy $x,$y" stroke="$fg" stroke-width="0.25" fill="$bg" />};
385                         #print qq{<polygon points="$x,$cy $cx,$cy $cx,$y $x,$cy" stroke="$bg" stroke-width="0.25" fill="$fg" />};
386                         print qq{<rect x="$x" y="$y" width="$w" height="2.54" stroke="$fg" stroke-width="0.3" fill="$bg" />};
387                         my ( $fg, $bg ) = @{ $cols->{txt} };
388                         print qq{<rect x="$x" y="$y" width="$w" height="2.54" rx="1" ry="1" stroke="$fg" stroke-width="0.3" fill="$bg" />};
389                 } else {
390                         rect $x,$y,$col,$fg;
391                 }
392                 return qq{ style="fill:$bg"};
393         }
394
395         if ( $name =~ m/(VCC|3V3|3.3V|5v)/i ) {
396                 my ($fg,$bg) = @{ $cols->{vcc} };
397                 rect $x,$y,$col,$bg;
398                 return qq{ style="fill:$fg"};
399         } elsif ( $name =~ m/(G(ND|Round)|VSS|0v)/i ) {
400                 my ($fg,$bg) = @{ $cols->{gnd} };
401                 rect $x,$y,$col,$bg;
402                 return qq{ style="fill:$fg"};
403         } elsif ( $name =~ m/\[(\w+)/ ) { # kernel
404                 my $dev = $1;
405                 my ($fg,$bg) = @{ $cols->{txt} };
406                 $dev = 'serial' if $dev =~ m/^tty/;
407                 ($fg,$bg) = @{ $cols->{$dev} } if exists $cols->{$dev};
408                 rect $x,$y,$col,$bg;
409                 return qq{ style="fill:$fg"};
410         } else {
411                 my ( $fg, $bg ) = @{ $cols->{txt} };
412                 rect $x,$y,$col,$bg;
413                 #return qq{ style="fill:$fg"};
414                 return '';
415         }
416 }
417
418 my $alt_col = 0;
419
420 my @cols_order = ( 0,1,2,3 );
421 my @cols_align = ( '','-','','-' ); # sprintf prefix
422
423 my @cols_shuffle = @cols_order;
424
425 if ( $opt_edge ) {
426         # pins outside on the right
427         @cols_shuffle = ( 0,1,3,2 ) if $opt_edge;
428         @cols_align = ( '-','-','','' );
429 } elsif ( $opt_middle ) {
430         # pins in middle
431         @cols_shuffle = ( 1,0,2,3 );
432         @cols_align = ( '','','-','-' );
433 }
434
435 sub cols_shuffle {
436         my ( $what, $order ) = @_;
437         my $new = [];
438         foreach my $i ( 0 .. $#$what ) {
439                 $new->[$i] = $what->[ $order->[$i] ];
440         }
441         warn "# cols_shuffle what=",dump($what)," order=",dump($order)," new=",dump($new);
442         return @$new;
443 }
444
445 @cols_order = cols_shuffle( \@cols_order, \@cols_shuffle );
446 @max_len    = cols_shuffle( \@max_len,    \@cols_shuffle );
447
448 warn "# cols_order = ",dump( \@cols_order );
449 warn "# cols_align = ",dump( \@cols_align );
450
451 my $fmt = "%$cols_align[0]$max_len[0]s %$cols_align[1]$max_len[1]s %$cols_align[2]$max_len[2]s %$cols_align[3]$max_len[3]s\n";
452
453
454 # cut marks
455 my ($fg,$bg) = @{ $cols->{txt} };
456 my $line_fmt = qq{<line x1="%s" y1="%s" x2="%s" y2="%s" style="stroke:$fg;stroke-width:0.10;fill:$bg" />\n};
457
458 my @cut_marks;
459 sub cut_mark {
460         my ($x,$y) = @_;
461         return unless $opt_svg;
462         push @cut_marks, sprintf($line_fmt, $x-5, $y-$font_b,   $x+5, $y-$font_b);
463         push @cut_marks, sprintf($line_fmt, $x,   $y-$font_b-5, $x,   $y-$font_b+5);
464 }
465 #cut_mark $x, $y;
466 my $max_x = $x;
467 $max_x += $max_len[$_] * $font_w foreach ( 0 .. 3 );
468 #cut_mark $max_x, $y;
469
470 sub line {
471         my ($x,$y,$max_x) = @_;
472         push @cut_marks, sprintf($line_fmt, $x, $y-$font_b, $max_x, $y-$font_b);
473 }
474
475
476 my $last_cut_mark = 0;
477
478 sub connector {
479         my ( $from, $to ) = @_;
480         warn "# connector $from - $to ",dump( $line_parts[$from], $line_parts[$to] );
481         if ( $opt_vertical ) {
482                 foreach my $i ( 0 .. int(($to-$from)/2) ) {
483                         my $t = $line_parts[$from + $i];
484                                 $line_parts[$from + $i] = $line_parts[$to - $i];
485                                                           $line_parts[$to - $i] = $t;
486                 }
487         }
488 }
489
490 my $from;
491 my $to;
492 foreach my $i ( 0 .. $#line_parts ) {
493         next if $line_parts[$i]->[0] =~ m/^###/;
494         if (exists $line_parts[$i]->[1]) {
495                 if (! $from) {
496                         $from = $i;
497                 } else {
498                         $to = $i;
499                 }
500         } elsif ($from && $to) {
501                 connector $from => $to;
502                 $from = $to = undef;
503         }
504 }
505 connector $from => $to if $from && $to;
506
507 foreach my $i ( 0 .. $#line_parts ) {
508 #       $i = $#line_parts - $i if $opt_vertical;
509         my $line = $line_parts[$i];
510
511         if ( $opt_svg ) {
512
513                 # not a minimal two column pin description
514                 if ( ! exists $line->[1] ) {
515                         $last_cut_mark = 1 if $line->[0] =~ m/^##/; # skip comments
516
517                         # before first empty line
518                         if ( $last_cut_mark == 0 ) {
519                                 cut_mark $x, $y;
520                                 cut_mark $max_x, $y;
521                                 $last_cut_mark = 1;
522                                 line $x, $y, $max_x if $opt_lines;
523                                 $y += 15; # make spacing between pinouts
524                         }
525                 } elsif ( $last_cut_mark ) {
526                         # first full line
527                         cut_mark $x, $y;
528                         cut_mark $max_x, $y;
529                         $last_cut_mark = 0;
530                 } else {
531                         #warn "CUTMARK no magic";
532                 }
533
534                 line $x, $y, $max_x if $opt_lines && exists $line->[1];
535
536                 my ($fg,$bg) = @{ $cols->{txt} };
537                 my $tspan = qq{<tspan x="$x" y="$y" style="line-height:2.54;fill:$fg;stroke:none;">\n};
538
539                 my $x_pos = $x;
540                 foreach my $i ( 0 .. $#cols_order ) {
541                         my $order = $cols_order[$i];
542                         next unless $line->[$order];
543
544                         my $text_anchor = 'middle';
545                         my $len = $max_len[$i];
546                         my $x2 = $x_pos + ( $len * $font_w ) / 2;
547                         # is this comment?
548                         if ( $#$line == 0 && $line->[$order] =~ s/^#+s*// ) {
549                                 # comment, center over whole width
550                                 $len = length($line->[$order]);
551                                 $x2 = $x + (($max_x-$x)/2); # middle
552                                 $tspan .= qq{\t<tspan x="$x2" text-anchor="$text_anchor"}.sprintf( '>%' . $cols_align[$i] . $len . 's</tspan>', $line->[0]);
553                         } else {
554                                 $tspan .= qq{\t<tspan x="$x2" text-anchor="$text_anchor"}.svg_style($line->[$order],$x_pos,$y,$i).sprintf( '>%' . $cols_align[$i] . $len . 's</tspan>', $line->[$order]);
555                         }
556                         $x_pos += $len * $font_w;
557                 }
558
559                 $tspan .= qq{\n</tspan>\n};
560                 push @later,sprintf $tspan, @$line;
561                 $y += 2.54;
562
563                 # swap pin colors for line stripe
564                 if ( $opt_zebra ) {
565                         swap_cols $_ foreach qw( pins txt );
566                 } else {
567                         swap_cols 'pins';
568                 }
569
570         } else {
571
572                 if ( $#$line == 0 ) {
573                         print $line->[0], "\n";
574                 } else {
575                         push @$line, '' while ($#$line < 3); # fill-in single row header
576                         printf $fmt, map { $line->[$_] } @cols_order;
577                 }
578
579         }
580 }
581
582 if ( $opt_svg ) {
583         cut_mark $x,$y;
584         cut_mark $max_x,$y;
585         line $x, $y, $max_x if $opt_lines;
586
587         print qq{
588     <text
589        id="text4506"
590        y="$x"
591        x="$y"
592        style="font-size:2.34px;line-height:2.54px;font-family:'Andale Mono';stroke:none"
593        xml:space="preserve">
594
595         }; #svg
596
597         print @later, qq{</text>\n}, @cut_marks, qq{</g>\n</svg>};
598
599 }
600
601 # you can add pin definitions below, but they should go into pins/
602 __DATA__
603