tools/winapi/winapi_function.pm

   1 #
   2 # Copyright 1999, 2000, 2001 Patrik Stridvall
   3 #
   4 # This library is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU Lesser General Public
   6 # License as published by the Free Software Foundation; either
   7 # version 2.1 of the License, or (at your option) any later version.
   8 #
   9 # This library is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # Lesser General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU Lesser General Public
  15 # License along with this library; if not, write to the Free Software
  16 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
  17 #
  18
  19 package winapi_function;
  20 use base qw(function);
  21
  22 use strict;
  23
  24 use config qw($current_dir $wine_dir);
  25 use util qw(normalize_set);
  26
  27 my $import = 0;
  28 use vars qw($modules $win16api $win32api @winapis);
  29
  30 ########################################################################
  31 # constructor
  32 #
  33
  34 sub new($) {
  35     my $proto = shift;
  36     my $class = ref($proto) || $proto;
  37     my $self  = {};
  38     bless ($self, $class);
  39
  40     if (!$import) {
  41         require modules;
  42         import modules qw($modules);
  43
  44         require winapi;
  45         import winapi qw($win16api $win32api @winapis);
  46
  47         $import = 1;
  48     }
  49     return $self;
  50 }
  51
  52 ########################################################################
  53 # is_win
  54 #
  55
  56 sub is_win16($) { my $self = shift; return defined($self->_module($win16api, @_)); }
  57 sub is_win32($) { my $self = shift; return defined($self->_module($win32api, @_)); }
  58
  59 ########################################################################
  60 # external_name
  61 #
  62
  63 sub _external_name($$) {
  64     my $self = shift;
  65     my $winapi = shift;
  66
  67     my $file = $self->file;
  68     my $internal_name = $self->internal_name;
  69
  70     my $external_name = $winapi->function_external_name($internal_name);
  71     my $module = $winapi->function_internal_module($internal_name);
  72
  73     if(!defined($external_name) && !defined($module)) {
  74         return undef;
  75     }
  76
  77     my @external_names = split(/\s*&\s*/, $external_name);
  78     my @modules = split(/\s*&\s*/, $module);
  79
  80     my @external_names2;
  81     while(defined(my $external_name = shift @external_names) &&
  82           defined(my $module = shift @modules))
  83     {
  84         if($modules->is_allowed_module_in_file($module, "$current_dir/$file")) {
  85             push @external_names2, $external_name;
  86         }
  87     }
  88
  89     return join(" & ", @external_names2);
  90 }
  91
  92 sub _external_names($$) {
  93     my $self = shift;
  94     my $winapi = shift;
  95
  96     my $external_name = $self->_external_name($winapi);
  97
  98     if(defined($external_name)) {
  99         return split(/\s*&\s*/, $external_name);
 100     } else {
 101         return ();
 102     }
 103 }
 104
 105 sub external_name($) {
 106     my $self = shift;
 107
 108     foreach my $winapi (@winapis) {
 109         my $external_name = $self->_external_name($winapi, @_);
 110
 111         if(defined($external_name)) {
 112             return $external_name;
 113         }
 114     }
 115
 116     return undef;
 117 }
 118
 119 sub external_name16($) { my $self = shift; return $self->_external_name($win16api, @_); }
 120 sub external_name32($) { my $self = shift; return $self->_external_name($win32api, @_); }
 121
 122 sub external_names16($) { my $self = shift; return $self->_external_names($win16api, @_); }
 123 sub external_names32($) { my $self = shift; return $self->_external_names($win32api, @_); }
 124
 125 sub external_names($) { my $self = shift; return ($self->external_names16, $self->external_names32); }
 126
 127 ########################################################################
 128 # module
 129 #
 130
 131 sub _module($$) {
 132     my $self = shift;
 133     my $winapi = shift;
 134
 135     my $file = $self->file;
 136     my $internal_name = $self->internal_name;
 137
 138     my $module = $winapi->function_internal_module($internal_name);
 139     if(!defined($module)) {
 140         return undef;
 141     }
 142
 143     if(!defined($file)) {
 144         return undef;
 145     }
 146
 147     my @modules;
 148     foreach my $module (split(/\s*&\s*/, $module)) {
 149         if($modules->is_allowed_module_in_file($module, "$current_dir/$file")) {
 150             push @modules, $module;
 151         }
 152     }
 153
 154     return join(" & ", @modules);
 155 }
 156
 157 sub _modules($$) {
 158     my $self = shift;
 159     my $winapi = shift;
 160
 161     my $module = $self->_module($winapi);
 162
 163     if(defined($module)) {
 164         return split(/\s*&\s*/, $module);
 165     } else {
 166         return ();
 167     }
 168 }
 169
 170 sub module16($) { my $self = shift; return $self->_module($win16api, @_); }
 171 sub module32($) { my $self = shift; return $self->_module($win32api, @_); }
 172
 173 sub module($) { my $self = shift; return join (" & ", $self->modules); }
 174
 175 sub modules16($) { my $self = shift; return $self->_modules($win16api, @_); }
 176 sub modules32($) { my $self = shift; return $self->_modules($win32api, @_); }
 177
 178 sub modules($) { my $self = shift; return ($self->modules16, $self->modules32); }
 179
 180 ########################################################################
 181 # ordinal
 182 #
 183
 184 sub _ordinal($$) {
 185     my $self = shift;
 186     my $winapi = shift;
 187
 188     my $file = $self->file;
 189     my $internal_name = $self->internal_name;
 190
 191     my $ordinal = $winapi->function_internal_ordinal($internal_name);
 192     my $module = $winapi->function_internal_module($internal_name);
 193
 194     if(!defined($ordinal) && !defined($module)) {
 195         return undef;
 196     }
 197
 198     my @ordinals = split(/\s*&\s*/, $ordinal);
 199     my @modules = split(/\s*&\s*/, $module);
 200
 201     my @ordinals2;
 202     while(defined(my $ordinal = shift @ordinals) &&
 203           defined(my $module = shift @modules))
 204     {
 205         if($modules->is_allowed_module_in_file($module, "$current_dir/$file")) {
 206             push @ordinals2, $ordinal;
 207         }
 208     }
 209
 210     return join(" & ", @ordinals2);
 211 }
 212
 213 sub _ordinals($$) {
 214     my $self = shift;
 215     my $winapi = shift;
 216
 217     my $ordinal = $self->_ordinal($winapi);
 218
 219     if(defined($ordinal)) {
 220         return split(/\s*&\s*/, $ordinal);
 221     } else {
 222         return ();
 223     }
 224 }
 225
 226 sub ordinal16($) { my $self = shift; return $self->_ordinal($win16api, @_); }
 227 sub ordinal32($) { my $self = shift; return $self->_ordinal($win32api, @_); }
 228
 229 sub ordinal($) { my $self = shift; return join (" & ", $self->ordinals); }
 230
 231 sub ordinals16($) { my $self = shift; return $self->_ordinals($win16api, @_); }
 232 sub ordinals32($) { my $self = shift; return $self->_ordinals($win32api, @_); }
 233
 234 sub ordinals($) { my $self = shift; return ($self->ordinals16, $self->ordinals32); }
 235
 236 ########################################################################
 237 # prefix
 238 #
 239
 240 sub prefix($) {
 241     my $self = shift;
 242     my $module16 = $self->module16;
 243     my $module32 = $self->module32;
 244
 245     my $file = $self->file;
 246     my $function_line = $self->function_line;
 247     my $return_type = $self->return_type;
 248     my $internal_name = $self->internal_name;
 249     my $calling_convention = $self->calling_convention;
 250
 251     my $refargument_types = $self->argument_types;
 252     my @argument_types = ();
 253     if(defined($refargument_types)) {
 254         @argument_types = @$refargument_types;
 255         if($#argument_types < 0) {
 256             @argument_types = ("void");
 257         }
 258     }
 259
 260     my $prefix = "";
 261
 262     my @modules = ();
 263     my %used;
 264     foreach my $module ($self->modules) {
 265         if($used{$module}) { next; }
 266         push @modules, $module;
 267         $used{$module}++;
 268     }
 269     $prefix .= "$file:";
 270     if(defined($function_line)) {
 271         $prefix .= "$function_line: ";
 272     } else {
 273         $prefix .= "<>: ";
 274     }
 275     if($#modules >= 0) {
 276         $prefix .= join(" & ", @modules) . ": ";
 277     } else {
 278         $prefix .= "<>: ";
 279     }
 280     $prefix .= "$return_type ";
 281     $prefix .= "$calling_convention " if $calling_convention;
 282     $prefix .= "$internal_name(" . join(",", @argument_types) . "): ";
 283
 284     return $prefix;
 285 }
 286
 287 ########################################################################
 288 # calling_convention
 289 #
 290
 291 sub calling_convention16($) {
 292     my $self = shift;
 293     my $return_kind16 = $self->return_kind16;
 294
 295     my $suffix;
 296     if(!defined($return_kind16)) {
 297         $suffix = undef;
 298     } elsif($return_kind16 =~ /^(?:void|s_word|word)$/) {
 299         $suffix = "16";
 300     } elsif($return_kind16 =~ /^(?:long|ptr|segptr|segstr|str|wstr)$/) {
 301         $suffix = "";
 302     } else {
 303         $suffix = undef;
 304     }
 305
 306     local $_ = $self->calling_convention;
 307     if($_ eq "__cdecl") {
 308         return "cdecl";
 309     } elsif(/^(?:VFWAPIV|WINAPIV)$/) {
 310         if(!defined($suffix)) { return undef; }
 311         return "pascal$suffix"; # FIXME: Is this correct?
 312     } elsif(/^(?:__stdcall|__RPC_STUB|__RPC_USER|NET_API_FUNCTION|RPC_ENTRY|VFWAPI|WINAPI|CALLBACK)$/) {
 313         if(!defined($suffix)) { return undef; }
 314         return "pascal$suffix";
 315     } elsif($_ eq "__asm") {
 316         return "asm";
 317     } else {
 318         return "cdecl";
 319     }
 320 }
 321
 322 sub calling_convention32($) {
 323     my $self = shift;
 324
 325     local $_ = $self->calling_convention;
 326     if($_ eq "__cdecl") {
 327         return "cdecl";
 328     } elsif(/^(?:VFWAPIV|WINAPIV)$/) {
 329         return "varargs";
 330     } elsif(/^(?:__stdcall|__RPC_STUB|__RPC_USER|NET_API_FUNCTION|RPC_ENTRY|VFWAPI|WINAPI|CALLBACK)$/) {
 331         return "stdcall";
 332     } elsif($_ eq "__asm") {
 333         return "asm";
 334     } else {
 335         return "cdecl";
 336     }
 337 }
 338
 339 sub get_all_module_ordinal16($) {
 340     my $self = shift;
 341     my $internal_name = $self->internal_name;
 342
 343     return winapi::get_all_module_internal_ordinal16($internal_name);
 344 }
 345
 346 sub get_all_module_ordinal32($) {
 347     my $self = shift;
 348     my $internal_name = $self->internal_name;
 349
 350     return winapi::get_all_module_internal_ordinal32($internal_name);
 351 }
 352
 353 sub get_all_module_ordinal($) {
 354     my $self = shift;
 355     my $internal_name = $self->internal_name;
 356
 357     return winapi::get_all_module_internal_ordinal($internal_name);
 358 }
 359
 360 sub _return_kind($$) {
 361     my $self = shift;
 362     my $winapi = shift;
 363     my $return_type = $self->return_type;
 364
 365     return $winapi->translate_argument($return_type);
 366 }
 367
 368 sub return_kind16($) {
 369     my $self = shift; return $self->_return_kind($win16api, @_);
 370 }
 371
 372 sub return_kind32($) {
 373     my $self = shift; return $self->_return_kind($win32api, @_);
 374 }
 375
 376 sub _argument_kinds($$) {
 377     my $self = shift;
 378     my $winapi = shift;
 379     my $refargument_types = $self->argument_types;
 380
 381     if(!defined($refargument_types)) {
 382         return undef;
 383     }
 384
 385     my @argument_kinds;
 386     foreach my $argument_type (@$refargument_types) {
 387         my $argument_kind = $winapi->translate_argument($argument_type);
 388
 389         if(defined($argument_kind) && $argument_kind eq "longlong") {
 390             push @argument_kinds, "double";
 391         } else {
 392             push @argument_kinds, $argument_kind;
 393         }
 394     }
 395
 396     return [@argument_kinds];
 397 }
 398
 399 sub argument_kinds16($) {
 400     my $self = shift; return $self->_argument_kinds($win16api, @_);
 401 }
 402
 403 sub argument_kinds32($) {
 404     my $self = shift; return $self->_argument_kinds($win32api, @_);
 405 }
 406
 407 ##############################################################################
 408 # Accounting
 409 #
 410
 411 sub function_called($$) {
 412     my $self = shift;
 413     my $called_function_names = \%{$self->{CALLED_FUNCTION_NAMES}};
 414
 415     my $name = shift;
 416
 417     $$called_function_names{$name}++;
 418 }
 419
 420 sub function_called_by($$) {
 421    my $self = shift;
 422    my $called_by_function_names = \%{$self->{CALLED_BY_FUNCTION_NAMES}};
 423
 424    my $name = shift;
 425
 426    $$called_by_function_names{$name}++;
 427 }
 428
 429 sub called_function_names($) {
 430     my $self = shift;
 431     my $called_function_names = \%{$self->{CALLED_FUNCTION_NAMES}};
 432
 433     return sort(keys(%$called_function_names));
 434 }
 435
 436 sub called_by_function_names($) {
 437     my $self = shift;
 438     my $called_by_function_names = \%{$self->{CALLED_BY_FUNCTION_NAMES}};
 439
 440     return sort(keys(%$called_by_function_names));
 441 }
 442
 443
 444 1;