1package ExtUtils::XSBuilder::FunctionMap;
2
3use strict;
4use warnings FATAL => 'all';
5use ExtUtils::XSBuilder::MapUtil qw(function_table structure_table);
6use Data::Dumper ;
7
8our @ISA = qw(ExtUtils::XSBuilder::MapBase);
9
10sub new {
11    my $class = shift;
12    bless {wrapxs => shift}, $class;
13}
14
15#for adding to function.map
16sub generate {
17    my $self = shift;
18
19    my $missing = $self->check;
20    return unless $missing;
21
22    print " $_\n" for @$missing;
23}
24
25sub disabled { shift->{disabled} }
26
27#look for functions that do not exist in *.map
28sub check {
29    my $self = shift;
30    my $map = $self->get;
31
32    my @missing;
33    my $parsesource = $self -> {wrapxs} -> parsesource_objects ;
34
35    loop:
36    for my $name (map $_->{name}, @{ function_table($self -> {wrapxs}) }) {
37        next if exists $map->{$name};
38        #foreach my $obj (@$parsesource)
39        #    {
40        #    next loop if ($obj -> handle_func ($name)) ;
41        #    }
42        push @missing, $name ;
43    }
44
45    return @missing ? \@missing : undef;
46}
47
48#look for functions in *.map that do not exist
49my $special_name = qr{(^DEFINE_|DESTROY$)};
50
51sub check_exists {
52    my $self = shift;
53
54    my %functions = map { $_->{name}, 1 } @{ function_table($self -> {wrapxs}) };
55    my @missing = ();
56
57    for my $name (keys %{ $self->{map} }) {
58        next if $functions{$name};
59        push @missing, $name unless $name =~ $special_name;
60    }
61
62    return @missing ? \@missing : undef;
63}
64
65my $keywords = join '|', qw(MODULE PACKAGE PREFIX BOOT);
66
67
68
69sub class_c_prefix {
70    my $self = shift;
71    my $class = shift;
72    $class =~ s/:/_/g;
73    $class;
74}
75
76sub class_xs_prefix {
77    my $self = shift;
78    my $class = shift;
79    my $class_prefix = $self -> class_c_prefix($class);
80    return $self -> {wrapxs} -> my_xs_prefix . $class_prefix . '_' ;
81}
82
83sub needs_prefix {
84    my $self = shift;
85    my $name = shift;
86    $self -> {wrapxs} -> needs_prefix ($name) ;
87}
88
89sub make_prefix {
90    my($self, $name, $class) = @_;
91    my $class_prefix = $self -> class_xs_prefix($class);
92    return $name if $name =~ /^$class_prefix/;
93    $class_prefix . $name;
94}
95
96
97sub guess_prefix {
98    my $self = shift;
99    my $entry = shift;
100
101    my($name, $class) = ($entry->{name}, $entry->{class});
102    my $prefix = "";
103    my $myprefix = $self -> {wrapxs} -> my_xs_prefix ;
104    $name =~ s/^DEFINE_//;
105    $name =~ s/^$myprefix//i;
106
107    (my $guess = lc($entry->{class} || $entry->{module}) . '_') =~ s/::/_/g;
108    $guess =~ s/(apache)_/($1|ap)_{1,2}/;
109
110    if ($name =~ s/^($guess).*/$1/i) {
111        $prefix = $1;
112    }
113    else {
114        if ($name =~ /^(apr?_)/) {
115            $prefix = $1;
116        }
117    }
118
119    #print "GUESS prefix=$guess, name=$entry->{name} -> $prefix\n";
120
121    return $prefix;
122}
123
124sub parse {
125    my($self, $fh, $map) = @_;
126    my %cur;
127    my $disabled = 0;
128
129    while ($fh->readline) {
130        if (/($keywords)=/o) {
131            $disabled = s/^\W//; #module is disabled
132            my %words = $self->parse_keywords($_);
133
134            if ($words{MODULE}) {
135                %cur = ();
136            }
137
138            if ($words{PACKAGE}) {
139                delete $cur{CLASS};
140            }
141
142            for (keys %words) {
143                $cur{$_} = $words{$_};
144            }
145
146            next;
147        }
148
149        my($name, $dispatch, $argspec, $alias) = split /\s*\|\s*/;
150
151        my $dispatch_argspec = '' ;
152
153        if ($dispatch && ($dispatch =~ m#\s*(.*?)\s*\((.*)\)#))
154            {
155            $dispatch = $1;
156            $dispatch_argspec = $2;
157            }
158
159        my $return_type;
160
161        if ($name =~ s/^([^:]+)://) {
162            $return_type = $1;
163        }
164
165        if ($name =~ s/^(\W)// or not $cur{MODULE} or $disabled) {
166            #notimplemented or cooked by hand
167            $map->{$name} = undef;
168            push @{ $self->{disabled}->{ $1 || '!' } }, $name;
169            next;
170        }
171
172        if (my $package = $cur{PACKAGE}) {
173            unless ($package eq 'guess') {
174                $cur{CLASS} = $package;
175            }
176            if ($cur{ISA}) {
177                $self->{isa}->{ $cur{MODULE} }->{$package} = delete $cur{ISA};
178            }
179            if ($cur{BOOT}) {
180                $self->{boot}->{ $cur{MODULE} } = delete $cur{BOOT};
181            }
182        }
183        else {
184            $cur{CLASS} = $cur{MODULE};
185        }
186
187        if ($name =~ /^DEFINE_/ and $cur{CLASS}) {
188            $name =~ s{^(DEFINE_)(.*)}
189              {$1 . $self->make_prefix($2, $cur{CLASS})}e;
190        print "DEFINE $name arg=$argspec\n" ;
191	}
192
193        my $entry = $map->{$name} = {
194           name        => $alias || $name,
195           dispatch    => $dispatch,
196           dispatch_argspec    => $dispatch_argspec,
197           argspec     => $argspec ? [split /\s*,\s*/, $argspec] : "",
198           return_type => $return_type,
199           alias       => $alias,
200        };
201
202        for (keys %cur) {
203            $entry->{lc $_} = $cur{$_};
204        }
205
206        #avoid 'use of uninitialized value' warnings
207        $entry->{$_} ||= "" for keys %{ $entry };
208        if ($entry->{dispatch} =~ /_$/) {
209            $entry->{dispatch} .= $name;
210        }
211    }
212}
213
214sub get {
215    my $self = shift;
216
217    $self->{map} ||= $self->parse_map_files;
218}
219
220sub prefixes {
221    my $self = shift;
222    $self = ExtUtils::XSBuilder::FunctionMap->new unless ref $self;
223
224    my $map = $self->get;
225    my %prefix;
226
227    while (my($name, $ent) = each %$map) {
228        next unless $ent->{prefix};
229        $prefix{ $ent->{prefix} }++;
230    }
231
232    $prefix{$_} = 1 for qw(ap_ apr_); #make sure we get these
233
234    [keys %prefix]
235}
236
237
238sub write {
239    my ($self, $fh, $newentries, $prefix) = @_ ;
240
241    foreach (@$newentries)
242        {
243        $fh -> print ($prefix, $self -> {wrapxs} -> mapline_func ($_), "\n") ;
244        }
245    }
246
2471;
248__END__
249