File Coverage

blib/lib/PDLA/PP/CType.pm
Criterion Covered Total %
statement 37 104 35.5
branch 6 42 14.2
condition n/a
subroutine 7 15 46.6
pod 0 14 0.0
total 50 175 28.5


line stmt bran cond sub pod time code
1             # Represent any C type.
2             # Type contains the size of arrays, which is either constant
3             # or resolved (into an object) from resolveobj.
4              
5             package PDLA::PP::CType;
6 2     2   15 use Carp;
  2         4  
  2         3389  
7              
8             # new PDLA::PP::CType(resolveobj,str)
9              
10             sub new {
11 7     7 0 18 my $this = bless {},shift;
12 7         21 $this->{Resolve} = shift;
13 7 50       19 if(@_) {
14 7         22 $this->parsefrom(shift);
15             }
16 7         31 return $this;
17             }
18              
19             sub stripptrs {
20 11     11 0 26 my($this,$str) = @_;
21 11 100       43 if($str =~ /^\s*\w+\s*$/) {
22 7         17 $str =~ s/\s//g;
23 7         17 $this->{ProtoName} = $str;
24 7         17 return [];
25             } else {
26             # Now, recall the different C syntaxes. First priority is a pointer:
27 4         7 my $decl;
28 4 50       19 if($str =~ /^\s*\*(.*)$/) {
    0          
    0          
29 4         18 $decl = $this->stripptrs($1);
30 4         12 unshift @$decl,"PTR";
31             } elsif($str =~ /^\s*\(.*\)\s*$/) {
32             # XXX Should try to see if a funccall.
33 0         0 return $this->stripptrs($1);
34             } elsif($str =~ /^(.*)\[([^]]+)\]\s*$/) {
35 0         0 my $siz = $2;
36 0 0       0 print "ARR($str): ($siz)\n" if $::PP_VERBOSE;
37 0         0 $decl = $this->stripptrs($1);
38 0         0 unshift @$decl,"ARR($siz)";
39 0 0       0 print "ARR($str): ($siz)\n" if $::PP_VERBOSE;
40             } else {
41 0         0 die("Invalid C type '$str'");
42             }
43 4         7 return $decl;
44             }
45             }
46              
47             # XXX Correct to *real* parsing. This is only a subset.
48             sub parsefrom {
49 7     7 0 24 my($this,$str) = @_;
50             # First, take the words in the beginning
51 7         42 $str =~ /^\s*((?:\w+\b\s*)+)([^[].*)$/;
52 7         20 my $base = $1; my $decl = $2;
  7         14  
53 7         17 my $foo = $this->stripptrs($decl);
54 7         28 $this->{Base} = $base;
55 7         14 $this->{Chain} = $foo;
56             }
57              
58             sub get_decl {
59 9     9 0 21 my($this,$name,$opts) = @_;
60 9         16 for(@{$this->{Chain}}) {
  9         20  
61 6 50       23 if($_ eq "PTR") {$name = "*$name"}
  6 0       17  
62             elsif($_ =~/^ARR\((.*)\)$/) {
63 0 0       0 if($opts->{VarArrays2Ptrs}) {
64 0         0 $name = "*$name";
65             } else {
66 0         0 $name = "($name)[$1]";
67             }
68             }
69 0         0 else { confess("Invalid decl") }
70             }
71 9         55 return "$this->{Base} $name";
72             }
73              
74             # Useful when parsing argument decls
75 3     3 0 7 sub protoname { return shift->{ProtoName} }
76              
77             sub get_copy {
78 0     0 0 0 my($this,$from,$to) = @_;
79 0         0 my ($prev,$close);
80 0 0       0 if($#{$this->{Chain}} >= 0) {
  0         0  
81             # strdup loses portability :(
82             return "($to) = malloc(strlen($from)+1); strcpy($to,$from);"
83 0 0       0 if $this->{Base} =~ /^\s*char\s*$/;
84             return "($to) = newSVsv($from);"
85 0 0       0 if $this->{Base} =~ /^\s*SV\s*$/;
86 0         0 my $code = $this->get_malloc($to,$from);
87 0         0 my ($deref0,$deref1) = ($from,$to);
88 0         0 for(@{$this->{Chain}}) {
  0         0  
89 0 0       0 if($_ eq "PTR") {confess("Cannot alloc pointer, must be array");}
  0 0       0  
90             elsif($_ =~/^ARR\((.*)\)$/) {
91 0         0 $no++;
92 0         0 $prev .= "
93             if(!$deref0) {$deref1=0;}
94             else {int __malloc_ind_$no;
95             for(__malloc_ind_$no = 0;
96             __malloc_ind_$no < $1;
97             __malloc_ind_$no ++) {";
98 0         0 $deref0 = $deref0."[__malloc_ind_$no]";
99 0         0 $deref1 = $deref1."[__malloc_ind_$no]";
100 0         0 $close .= "}}";
101 0         0 } else { confess("Invalid decl $_") }
102             }
103 0         0 $code .= "$prev $deref1 = $deref0; $close";
104 0         0 return $code;
105             }
106 0         0 return "($to) = ($from);";
107             }
108              
109             sub get_free {
110 3     3 0 8 my($this,$from) = @_;
111 3         5 my ($prev,$close);
112 3 50       4 if($#{$this->{Chain}} >= 0) {
  3         8  
113             return "free($from);"
114 0 0       0 if $this->{Base} =~ /^\s*char\s*$/;
115             return "SvREFCNT_dec($from);"
116 0 0       0 if $this->{Base} =~ /^\s*SV\s*$/;
117 0         0 my @mallocs;
118 0         0 my $str = "{";
119 0         0 my $deref = "$from";
120 0         0 my $prev = undef;
121 0         0 my $close = undef;
122 0         0 my $no = 0;
123 0         0 for(@{$this->{Chain}}) {
  0         0  
124 0         0 $no++;
125 0 0       0 if($no > 1) {croak("Can only free one layer!\n");}
  0         0  
126             # if($_ eq "PTR") {confess("Cannot free pointer, must be array ;) (FIX CType.pm)");}
127 0         0 return "free($from);\n ";
128             }
129             } else {
130 3         10 "";
131             }
132             }
133              
134             sub need_malloc {
135 0     0 0   my($this) = @_;
136 0           return scalar grep /(ARR|PTR)/,(@{$this->{Chain}})
  0            
137             }
138              
139             # Just returns with the array string.
140             sub get_malloc {
141 0     0 0   my($this,$assignto) = @_;
142 0           my $str = "{";
143 0           my $deref = "$assignto";
144 0           my $prev = undef;
145 0           my $close = undef;
146 0           my $no = 0;
147 0           for(@{$this->{Chain}}) {
  0            
148 0 0         if($_ eq "PTR") {confess("Cannot alloc pointer, must be array");}
  0 0          
149             elsif($_ =~/^ARR\((.*)\)$/) {
150 0           $str .= "$prev $assignto =
151             malloc(sizeof(* $assignto) * $1);
152             ";
153 0           $no++;
154 0           $prev = "{int __malloc_ind_$no;
155             for(__malloc_ind_$no = 0;
156             __malloc_ind_$no < $1;
157             __malloc_ind_$no ++) {";
158 0           $deref = $deref."[__malloc_ind_$no]";
159 0           $close .= "}}";
160 0           } else { confess("Invalid decl $_") }
161             }
162 0           $str .= "}";
163 0           return $str;
164             }
165              
166       0 0   sub getvar {
167             }
168              
169             # Determine if everything constant and can just declare
170       0 0   sub need_alloc {
171             }
172              
173       0 0   sub alloccode {
174             }
175              
176       0 0   sub copycode {
177             }
178              
179       0 0   sub freecode {
180             }
181              
182             1;