package OpenGL::Spec;

# A very simple task further complicated by the fact that some people

# can't read, others use legacy Operating Systems, and others don't give

# a damn about using a halfway decent text editor.

#

# The code to parse the _template_ is so simple and straightforward...

# yet the code to parse the real spec files is this mess.

my %typemap = (

    bitfield    => "GLbitfield",

    boolean     => "GLboolean",

    # fsck up in EXT_vertex_array

    Boolean     => "GLboolean",

    byte        => "GLbyte",

    clampd      => "GLclampd",

    clampf      => "GLclampf",

    double      => "GLdouble",

    enum        => "GLenum",

    # Intel fsck up

    Glenum      => "GLenum",

    float       => "GLfloat",

    half        => "GLuint",

    int         => "GLint",

    short       => "GLshort",

    sizei       => "GLsizei",

    ubyte       => "GLubyte",

    uint        => "GLuint",

    ushort      => "GLushort",

    DMbuffer    => "void *",

    # ARB VBO introduces these

    sizeiptrARB => "GLsizeiptrARB",

    intptrARB   => "GLintptrARB",

    # ARB shader objects introduces these, charARB is at least 8 bits,

    # handleARB is at least 32 bits

    charARB     => "GLcharARB",

    handleARB   => "GLhandleARB",

    # GLX 1.3 defines new types which might not be available at compile time

    #GLXFBConfig   => "void*",

    #GLXFBConfigID => "XID",

    #GLXContextID  => "XID",

    #GLXWindow     => "XID",

    #GLXPbuffer    => "XID",

    # Weird stuff for some SGIX extension

    #GLXFBConfigSGIX   => "void*",

    #GLXFBConfigIDSGIX => "XID",

);

my %void_typemap = (

    void    => "GLvoid",

);

my $section_re  = qr{^[A-Z]};

my $function_re = qr{^(.+) ([a-z][a-z0-9_]*) \((.+)\)$}i;

my $token_re    = qr{^([A-Z0-9][A-Z0-9_]*):?\s+((?:0x)?[0-9A-F]+)(.*)$};

my $prefix_re   = qr{^(?:AGL | GLX | WGL)_}x;

my $eofnc_re    = qr{ \);?$ | ^$ }x;

my $function_re = qr{^(.+) ([a-z][a-z0-9_]*) \((.+)\)$}i;

my $prefix_re   = qr{^(?:gl | agl | wgl | glX)}x;

my $types_re    = __compile_wordlist_cap(keys %typemap);

my $voidtype_re = __compile_wordlist_cap(keys %void_typemap);

sub new($)

{

    my $class = shift;

    my $self = { section => {} };

    $self->{filename} = shift;

    local $/;

    open(my $fh, "<$self->{filename}") or die "Can't open $self->{filename}";

    my $content = <$fh>;

    my $section;

    my $s = $self->{section};

    $content =~ s{[ \t]+$}{}mg;

    # Join lines that end with a word-character and ones that *begin*

    # with one

    $content =~ s{(\w)\n(\w)}{$1 $2}sg;

    foreach (split /\n/, $content)

    {

        if (/$section_re/)

        {

            chomp;

            s/^Name String$/Name Strings/; # Fix common mistake

            $section = $_;

            $s->{$section} = "";

        }

        elsif (defined $section and exists $s->{$section})

        {

            s{^\s+}{}mg; # Remove leading whitespace

            $s->{$section} .= $_ . "\n";

        }

    }

    $s->{$_} =~ s{(?:^\n+|\n+$)}{}s foreach keys %$s;

    bless $self, $class;

}

sub sections()

{

    my $self = shift;

    keys %{$self->{section}};

}

sub name()

{

    my $self = shift;

    $self->{section}->{Name};

}

sub name_strings()

{

    my $self = shift;

    split("\n", $self->{section}->{"Name Strings"});

}

sub tokens()

{

    my $self = shift;

    my %tokens = ();

    foreach (split /\n/, $self->{section}->{"New Tokens"})

    {

        next unless /$token_re/;

        my ($name, $value) = ($1, $2);

        $name =~ s{^}{GL_} unless $name =~ /$prefix_re/;

        $tokens{$name} = $value;

    }

    return %tokens;

}

sub functions()

{

    my $self = shift;

    my %functions = ();

    my @fnc = ();

    foreach (split /\n/, $self->{section}->{"New Procedures and Functions"})

    {

        push @fnc, $_ unless ($_ eq "" or $_ eq "None");

        next unless /$eofnc_re/;

        if (__normalize_proto(@fnc) =~ /$function_re/)

        {

            my ($return, $name, $parms) = ($1, $2, $3);

            if (!__ignore_function($name, $extname))

            {

                $name =~ s/^/gl/ unless $name =~ /$prefix_re/;

                if ($name =~ /^gl/ && $name !~ /^glX/)

                {

                    $return =~ s/$types_re/$typemap{$1}/g;

                    $return =~ s/$voidtype_re/$void_typemap{$1}/g;

                    $parms  =~ s/$types_re/$typemap{$1}/g;

                    $parms  =~ s/$voidtype_re/$void_typemap{$1}/g;

                }

                $functions{$name} = {

                    rtype => $return,

                    parms => $parms,

                };

            }

        }

        @fnc = ();

    }

    return %functions;

}

sub __normalize_proto

{

    local $_ = join(" ", @_);

    s/\s+/ /g;                # multiple whitespace -> single space

    s/\s*\(\s*/ \(/;          # exactly one space before ( and none after

    s/\s*\)\s*/\)/;           # no after before or after )

    s/\s*\*([a-zA-Z])/\* $1/; # "* identifier" XXX: g missing?

    s/\*wgl/\* wgl/;          # "* wgl"        XXX: why doesn't the

    s/\*glX/\* glX/;          # "* glX"             previous re catch this?

    s/\.\.\./void/;           # ... -> void

    s/;$//;                   # remove ; at the end of the line

    return $_;

}

sub __ignore_function

{

    return 0;

}

sub __compile_regex

{

    my $regex = join('', @_);

    return qr/$regex/

}

sub __compile_wordlist_cap

{

    __compile_regex('\b(', join('|', @_), ')\b');

}