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