1################################################################################
2#
3# Copyright (c) 2002-2020 Marcus Holland-Moritz. All rights reserved.
4# This program is free software; you can redistribute it and/or modify
5# it under the same terms as Perl itself.
6#
7################################################################################
8
9use Test;
10use Convert::Binary::C @ARGV;
11
12$^W = 1;
13
14BEGIN {
15  plan tests => 417;
16}
17
18my $CCCFG = require './tests/include/config.pl';
19
20%basic = ( char => 1, short => 1, int => 1,
21           long => 1, signed => 1, unsigned => 1,
22           float => 1, double => 1, void => 1 );
23
24eval {
25  $c = Convert::Binary::C->new(
26         ShortSize    => 2,
27         IntSize      => 4,
28         LongSize     => 4,
29         LongLongSize => 8,
30         EnumSize     => 4,
31         PointerSize  => 4,
32         Alignment    => 4,
33       )->parse( <<ENDC );
34
35typedef struct {
36  int    a;
37  short  b[3][1];
38  long  *c;
39  char   d;
40  char  *e[2];
41} Typedef, *PTypedef, ATypedef[2][3];
42
43struct Struct {
44  char  *a[2][2];
45  struct {
46    int  a;
47    enum {
48      ENUM
49    }    b[2], *c;
50  }      b[3], *c[2];
51};
52
53union Union {
54  struct {
55    char  color[2];
56    long  size;
57    union {
58      struct {
59        char a;
60      }     foo;
61      char  taste;
62    }     stuff;
63  }       apple;
64  char    grape[3];
65  struct {
66    union {
67      long  weight;
68      short foo;
69      enum { FOO } test;
70      struct {
71        char  a;
72        union {
73          short b;
74          char  c;
75        };
76      }     compound;
77    };
78    short price[3];
79  }       melon;
80};
81
82enum Enum {
83  ZERO
84};
85
86struct Main {
87  Typedef       a[2], *b, *c[3][4];
88  struct Struct d[1][2], *e, *f[2];
89  union Union   g, *h;
90  enum Enum     i, *j, k[3], *l[2][3];
91  int           m, *n, *o[4];
92  PTypedef      p[2], *q, *r[3][4];
93  ATypedef      s[2], *t, *u[3][4];
94};
95
96typedef struct {
97  int foo;
98} Array[2];
99
100typedef struct {
101  Array bar;
102} Type;
103
104ENDC
105};
106ok($@,'',"failed to create object / parse code");
107
108@ref = (
109  { members => [qw(.apple.color[0] .grape[0] .melon.weight .melon.foo .melon.test .melon.compound.a)],
110    types   => [qw(char            char      long          short      enum        char             )], },
111  { members => [qw(.apple.color[1] .grape[1] .melon.weight+1 .melon.foo+1 .melon.test+1 .melon.compound+1)],
112    types   => [qw(char            char      long            short        enum          struct           )], },
113  { members => [qw(.grape[2] .melon.compound.b .melon.compound.c .melon.weight+2 .melon.test+2 .apple+2)],
114    types   => [qw(char      short             char              long            enum          struct  )], },
115  { members => [qw(.melon.weight+3 .melon.test+3 .melon.compound.b+1 .apple+3)],
116    types   => [qw(long            enum          short               struct  )], },
117  { members => [qw(.apple.size .melon.price[0])],
118    types   => [qw(long        short          )], },
119  { members => [qw(.apple.size+1 .melon.price[0]+1)],
120    types   => [qw(long          short            )], },
121  { members => [qw(.melon.price[1] .apple.size+2)],
122    types   => [qw(short           long         )], },
123  { members => [qw(.apple.size+3 .melon.price[1]+1)],
124    types   => [qw(long          short            )], },
125  { members => [qw(.apple.stuff.foo.a .apple.stuff.taste .melon.price[2])],
126    types   => [qw(char               char               short          )], },
127  { members => [qw(.melon.price[2]+1 .apple+9)],
128    types   => [qw(short             struct  )], },
129  { members => [qw(.apple+10 .melon+10)],
130    types   => [qw(struct    struct   )], },
131  { members => [qw(.apple+11 .melon+11)],
132    types   => [qw(struct    struct   )], },
133);
134
135for my $off ( 0 .. $c->sizeof( 'Union' )-1 ) {
136  my @members = eval { $c->member( 'Union', $off ) };
137  ok( $@, '' );
138  for( 0 .. $#members ) {
139    my $type = eval { $c->typeof( "Union $members[$_]" ) };
140    ok( $@, '' );
141    ok( $members[$_], $ref[$off]{members}[$_] );
142    ok( $type, $ref[$off]{types}[$_] );
143  }
144}
145
146run_tests($c);
147
148eval {
149  $c->configure(%$CCCFG)->clean->parse_file( 'tests/include/include.c' );
150};
151ok($@,'',"failed to create Convert::Binary::C object");
152
153run_tests($c);
154
155sub run_tests {
156  my $c = shift;
157
158  for my $mtype ( $c->compound_names ) {
159    my @warn;
160    local $SIG{__WARN__} = sub { push @warn, $_[0] };
161    my $fail = 0;
162    my $success = 0;
163    my $sizeof = $c->sizeof($mtype);
164    for my $off ( 0 .. $sizeof ) {
165      my @warn;
166      my $member = eval { $c->member( $mtype, $off ) };
167      if( $off == $sizeof ) {
168        unless( $@ =~ /Offset $off out of range \(0 <= offset < $sizeof\)/ ) {
169          print "# wrong error\n";
170          $fail++;
171        }
172        else { $success++ }
173      }
174      else {
175        unless( $@ eq '' ) {
176          print "# unexpected error\n";
177          $fail++;
178        }
179        else { $success++ }
180        my @members = eval { $c->member( $mtype, $off ) };
181        unless( $@ eq '' ) {
182          print "# unexpected error\n";
183          $fail++;
184        }
185        else { $success++ }
186        unless( @members > 0 and $members[0] eq $member ) {
187          print "# wrong members in list context\n";
188          $fail++;
189        }
190        else { $success++ }
191        for $member( @members ) {
192          my $type = eval { $c->typeof( "$mtype $member" ) || '[pad]' };
193          unless( $@ eq '' ) {
194            print "# unexpected error\n";
195            $fail++;
196          }
197          else { $success++ }
198          my $offset = eval { $c->offsetof($mtype, $member) };
199          unless( $@ eq '' ) {
200            print "# unexpected error\n";
201            $fail++;
202          }
203          else { $success++ }
204          unless( $offset == $off ) {
205            print "# invalid offset\n";
206            $fail++;
207          }
208          else { $success++ }
209          $member =~ s/\+\d+$//;
210          while( $member ) {
211            my $typeof = eval { $c->typeof("$mtype $member") };
212            unless( $@ eq '' ) {
213              print "# unexpected error\n";
214              $fail++;
215            }
216            else { $success++ }
217            unless( defined $typeof ) {
218              print "# undefined type\n";
219              $fail++;
220            }
221            else { $success++ }
222            $member =~ s/(?:\[\d+\]|\.\w+|^\w+)$//;
223          }
224        }
225      }
226    }
227    for( @warn ) {
228      print "# wrong warning\n";
229      $fail++;
230    }
231    ok( $fail == 0 );
232    ok( $success > 0 );
233  }
234
235  for my $t ( $c->compound_names, $c->typedef_names ) {
236    my %h;
237    my @m;
238    my $fail = 0;
239    my $success = 0;
240    my $meth = $c->def($t) or next;
241    my $def = $c->$meth( $t );
242
243    $meth eq 'typedef' and $h{$t} = $t;
244    get_types( \%h, \@m, $c, $t, $def );
245
246    while( my($k,$v) = each %h ) {
247      my $to = $c->typeof($k);
248      unless( $to eq $v ) {
249        print "# typeof mismatch for $meth <$k> ('$to' != '$v')\n";
250        $fail++;
251      }
252      else { $success++ }
253    }
254    ok( $fail == 0 );
255    ok( $success > 0 );
256
257    if( @m >= 2 ) {
258      $fail = $success = 0;
259      my %dup;
260      for my $member ( $c->member($t) ) {
261        my $ref = shift @m;
262        warn "[$t][$member]" unless defined $ref;
263        if( $t.$member ne $ref ) {
264          print "# '$t$member' ne '$ref'\n";
265          $fail++;
266        }
267        else { $success++ }
268        if( $dup{$member}++ ) {
269          print "# duplicate member '$t$member' (count=$dup{$member})\n";
270          $fail++;
271        }
272        else { $success++ }
273      }
274      ok( $fail == 0 );
275      ok( $success > 0 );
276    }
277  }
278}
279
280
281sub get_types {
282  my($r, $m, $c, $t, $d) = @_;
283  if( exists $d->{declarator} ) {
284    my($p,$n,$a) = $d->{declarator} =~ /^(\*?)(\w+)((?:\[\])?(?:\[\d+\])*)$/ or die "BOO!";
285    my $dim = [$a =~ /\[(\d+)?\]/g];
286    get_array($r, $m, $c, $t, $d->{type}, $p, $dim);
287  }
288  elsif( exists $d->{declarations} ) {
289    # it's a compound
290    for my $d1 ( @{$d->{declarations}} ) {
291      if( exists $d1->{declarators} ) {
292        for my $d2 ( @{$d1->{declarators}} ) {
293          my($p,$n,$b,$a) = $d2->{declarator} =~ /^(\*?)(\w*)(:\d+)?((?:\[\])?(?:\[\d+\])*)$/ or die "BOO!";
294          defined $b and $n eq '' and next;
295          my $dim = [$a =~ /\[(\d+)?\]/g];
296          get_array($r, $m, $c, "$t.$n", $b ? "$d1->{type} $b" : $d1->{type}, $p, $dim);
297        }
298      }
299      else {
300        get_types($r, $m, $c, $t, $d1->{type});
301      }
302    }
303  }
304  else {
305    push @$m, $t;
306  }
307}
308
309sub get_array {
310  my($r, $m, $c, $t, $d, $p, $dim) = @_;
311  my $rt;
312
313  if( ref $d ) {
314    if( exists $d->{declarations} ) {
315      $rt = $d->{type};
316    }
317    elsif( exists $d->{enumerators} ) {
318      $rt = 'enum';
319    }
320    else { die "BOO!" }
321  }
322  else { $rt = $d }
323
324  my $a = join '', map { defined $_ ? "[$_]" : '[]' } @$dim;
325
326  $p and $rt .= " $p";
327  $a and $rt .= " $a";
328
329  $r->{$t} ||= $rt;
330
331  if( @$dim ) {
332    my @dim = @$dim;
333    my $cd = shift @dim;
334    defined $cd or return; # don't add incomplete types
335    for my $i ( 0 .. $cd-1 ) {
336      get_array($r, $m, $c, $t."[$i]", $d, $p, \@dim);
337    }
338  }
339  elsif( !$p ) {
340    if( ref $d ) {
341      get_types($r, $m, $c, $t.$a, $d);
342    }
343    else {
344      if( $d =~ /^(?:struct|union)/ ) {
345        get_types($r, $m, $c, $t.$a, $c->compound($d));
346      }
347      elsif( $d =~ /^enum\s+\w+/ ) {
348        push @$m, $t;
349      }
350      elsif( $d =~ /^\w+$/ and not exists $basic{$d} ) {
351        get_types($r, $m, $c, $t.$a, $c->typedef($d));
352      }
353      else {
354        push @$m, $t;
355      }
356    }
357  }
358  else {
359    push @$m, $t;
360  }
361}
362