kc3-lang/SDL/src/dynapi/gendynapi.pl

Branch : - branch - v2.28 - tag -

• Show log

  Commit

• Author : Sam Lantinga
  Date : 2017-01-01 18:33:28
  Hash : 45b774e3
  Message : Updated copyright for 2017

• src/dynapi/gendynapi.pl

• #!/usr/bin/perl -w
  
  #  Simple DirectMedia Layer
  #  Copyright (C) 1997-2017 Sam Lantinga <slouken@libsdl.org>
  #
  #  This software is provided 'as-is', without any express or implied
  #  warranty.  In no event will the authors be held liable for any damages
  #  arising from the use of this software.
  #
  #  Permission is granted to anyone to use this software for any purpose,
  #  including commercial applications, and to alter it and redistribute it
  #  freely, subject to the following restrictions:
  #
  #  1. The origin of this software must not be misrepresented; you must not
  #     claim that you wrote the original software. If you use this software
  #     in a product, an acknowledgment in the product documentation would be
  #     appreciated but is not required.
  #  2. Altered source versions must be plainly marked as such, and must not be
  #     misrepresented as being the original software.
  #  3. This notice may not be removed or altered from any source distribution.
  
  # WHAT IS THIS?
  #  When you add a public API to SDL, please run this script, make sure the
  #  output looks sane (hg diff, it adds to existing files), and commit it.
  #  It keeps the dynamic API jump table operating correctly.
  
  # If you wanted this to be readable, you shouldn't have used perl.
  
  use warnings;
  use strict;
  use File::Basename;
  
  chdir(dirname(__FILE__) . '/../..');
  my $sdl_dynapi_procs_h = "src/dynapi/SDL_dynapi_procs.h";
  my $sdl_dynapi_overrides_h = "src/dynapi/SDL_dynapi_overrides.h";
  
  my %existing = ();
  if (-f $sdl_dynapi_procs_h) {
      open(SDL_DYNAPI_PROCS_H, '<', $sdl_dynapi_procs_h) or die("Can't open $sdl_dynapi_procs_h: $!\n");
      while (<SDL_DYNAPI_PROCS_H>) {
          if (/\ASDL_DYNAPI_PROC\(.*?,(.*?),/) {
              $existing{$1} = 1;
          }
      }
      close(SDL_DYNAPI_PROCS_H)
  }
  
  open(SDL_DYNAPI_PROCS_H, '>>', $sdl_dynapi_procs_h) or die("Can't open $sdl_dynapi_procs_h: $!\n");
  open(SDL_DYNAPI_OVERRIDES_H, '>>', $sdl_dynapi_overrides_h) or die("Can't open $sdl_dynapi_overrides_h: $!\n");
  
  opendir(HEADERS, 'include') or die("Can't open include dir: $!\n");
  while (readdir(HEADERS)) {
      next if not /\.h\Z/;
      my $header = "include/$_";
      open(HEADER, '<', $header) or die("Can't open $header: $!\n");
      while (<HEADER>) {
          chomp;
          next if not /\A\s*extern\s+DECLSPEC/;
          my $decl = "$_ ";
          if (not $decl =~ /\)\s*;/) {
              while (<HEADER>) {
                  chomp;
                  s/\A\s+//;
                  s/\s+\Z//;
                  $decl .= "$_ ";
                  last if /\)\s*;/;
              }
          }
  
          $decl =~ s/\s+\Z//;
          #print("DECL: [$decl]\n");
  
          if ($decl =~ /\A\s*extern\s+DECLSPEC\s+(const\s+|)(unsigned\s+|)(.*?)\s*(\*?)\s*SDLCALL\s+(.*?)\s*\((.*?)\);/) {
              my $rc = "$1$2$3$4";
              my $fn = $5;
  
              next if $existing{$fn};   # already slotted into the jump table.
  
              my @params = split(',', $6);
  
              #print("rc == '$rc', fn == '$fn', params == '$params'\n");
  
              my $retstr = ($rc eq 'void') ? '' : 'return';
              my $paramstr = '(';
              my $argstr = '(';
              my $i = 0;
              foreach (@params) {
                  my $str = $_;
                  $str =~ s/\A\s+//;
                  $str =~ s/\s+\Z//;
                  #print("1PARAM: $str\n");
                  if ($str eq 'void') {
                      $paramstr .= 'void';
                  } elsif ($str eq '...') {
                      if ($i > 0) {
                          $paramstr .= ', ';
                      }
                      $paramstr .= $str;
                  } elsif ($str =~ /\A\s*((const\s+|)(unsigned\s+|)([a-zA-Z0-9_]*)\s*([\*\s]*))\s*(.*?)\Z/) {
                      #print("PARSED: [$1], [$2], [$3], [$4], [$5]\n");
                      my $type = $1;
                      my $var = $6;
                      $type =~ s/\A\s+//;
                      $type =~ s/\s+\Z//;
                      $var =~ s/\A\s+//;
                      $var =~ s/\s+\Z//;
                      $type =~ s/\s*\*\Z/*/g;
                      $type =~ s/\s*(\*+)\Z/ $1/;
                      #print("SPLIT: ($type, $var)\n");
                      my $name = chr(ord('a') + $i);
                      if ($i > 0) {
                          $paramstr .= ', ';
                          $argstr .= ',';
                      }
                      my $spc = ($type =~ /\*\Z/) ? '' : ' ';
                      $paramstr .= "$type$spc$name";
                      $argstr .= "$name";
                  }
                  $i++;
              }
  
              $paramstr = '(void' if ($i == 0);  # Just to make this consistent.
  
              $paramstr .= ')';
              $argstr .= ')';
  
              print("NEW: $decl\n");
              print SDL_DYNAPI_PROCS_H "SDL_DYNAPI_PROC($rc,$fn,$paramstr,$argstr,$retstr)\n";
              print SDL_DYNAPI_OVERRIDES_H "#define $fn ${fn}_REAL\n";
          } else {
              print("Failed to parse decl [$decl]!\n");
          }
      }
      close(HEADER);
  }
  closedir(HEADERS);
  
  close(SDL_DYNAPI_PROCS_H);
  close(SDL_DYNAPI_OVERRIDES_H);
  
  # vi: set ts=4 sw=4 expandtab: