DBD::iPod::parser - parse iPod SQL queries

package DBD::iPod::parser;
use strict;
use base qw(SQL::Parser);
our $VERSION = '0.01';

use vars qw($FIELD_RE $FUNC_RE);

use Carp qw(carp);
use Data::Dumper;
use SQL::Parser;

# Package-scoped variables
# These are not lexicals so that they can be used in tests
$FIELD_RE = '[a-zA-Z][a-zA-Z0-9_]';
$FUNC_RE  = qr/$FIELD_RE*/; # methods?
$FIELD_RE = qr/$FIELD_RE*/;

my @default_columns = sort qw(
                              bitrate
                              fdesc
                              stoptime
                              songs
                              time
                              srate
                              rating
                              cdnum
                              cds
                              playcount
                              starttime
                              id
                              prerating
                              volume
                              songnum
                              path
                              genre
                              filesize
                              artist
                              album
                              comment
                              title
                              uniq
                             );

my %allowed_columns = map { $_ => 1 } @default_columns;
for my $dc (@default_columns) {
  $dc =~ s/([A-Z])/_\l$1/g;
  $allowed_columns{$dc} = 1;
}

# All functions are passed two items: the Net::Google::Search
# instanace and the text to be fiddled with.
my %functions = (
    'default'       => sub { $_[1]                  },
    'count'         => \&count,
);
$functions{''} = $functions{'default'};

# ----------------------------------------------------------------------
# new(@stuff)
# 
# Override SQL::Parser's new method, but only so that default values
# can be used.
# ----------------------------------------------------------------------
sub new { return shift->SUPER::new("iPod", @_) }

# ----------------------------------------------------------------------
# SELECT_CLAUSE($sql)
#
# Parses the SELECT portion of $sql, which contains only the pieces
# between SELECT and WHERE.  Understands the following syntax:
#
#   field
#
#   field AS alias
#
#   field AS "alias"
#
#   function(field)
#
#   function(field) AS alias
#
#   function(field) AS "alias"
#
# ----------------------------------------------------------------------
sub SELECT_CLAUSE {
  my ($self, $sql) = @_;
  #warn "Got: \$sql => '$sql'\n";
  my ($columns, $limit, @columns, @limit, $where, $parsed);

  # Internal data structures, given shorter names
  my $column_names =  $self->{'struct'}->{'column_names'}     = [ ];
  my $ORG_NAME     =  $self->{'struct'}->{'ORG_NAME'}         = { };
  my $functions    =  $self->{'struct'}->{'column_functions'} = { };
  my $aliases      =  $self->{'struct'}->{'column_aliases'}   = { };
  my $errstr       = \$self->{'struct'}->{'errstr'};

  # columns
  while ($sql =~ /\G

                                                # Field name, including possible function
                                                (?:
                                                    ($FUNC_RE\s*\([^)]+\))    # $1 => function
                                                |
                                                    ($FIELD_RE)               # $2 => field name
                                                | (\*)                      # $3 => '*'
                                                )

                                                # possible alias
                                                (?:
                                                        \s+
                                                        [aA][sS]
                                                        \s+
                                                        (['"]?)                 # $4 => possibly quoted
                                                            \s*
                                                            ($FIELD_RE)           # $5 => alias (no spaces allowed!)
                                                            \s*
                                                        \4?
                                                )?
                                                \s*
                                                ,?
                                                \s*
                                              /xsmg) {
    my $alias = $5 || "";
    my $function = $1 || "";

    #warn "\$function => '$function'\n\$alias => '$alias'\n";

    if (defined $3) {
      # SELECT * -> expanded to all column names
      my $df = $functions{'default'};
      for (@default_columns) {
        my $uc_ = uc $_;

        push @$column_names   => $_  ;
        $ORG_NAME->{  $uc_ }  =  $_  ;
        $functions->{ $uc_ }  =  $df ;
        $aliases->{   $uc_ }  =  $_  ;
      }
    }
    elsif ($function) {
      # SELECT foo(bar)
      my $original = $function;
      $original =~ /($FUNC_RE)\s*\((.*?)\)/;

      # XXX $n here might contains arguments; needs to be
      # passed to String::Shellquote to extract tokens
      my ($f, $n) = ($1, $2);
      $n =~ s/(^\s*|\s*$)//g;
      $f = "" unless defined $f;

      unless ($allowed_columns{$n}) {
        $$errstr = "Unknown column name '$n'";
        return;
      }

      # Possible cases include:
      #   1. No function defined
      #   2. Function defined that we know about
      if (defined $functions{$f}) {
        # Common case:
        #
        #   SELECT html_strip(title) FROM google ...
        #
        # A pre-defined function.
        $f = $functions{$f};
      }
      else {
        # No function:
        #
        #   SELECT title FROM google ...
        $f = $functions{'default'};
      }

      my $uc = uc $n;
      push @$column_names, $n;
      $ORG_NAME->{  $uc } = $n;
      $functions->{ $uc } = $f;
      $aliases->{   $uc } = $alias ? $alias : $n;
    }
    elsif (defined $2) {
      my $lc = lc $2;
      my $uc = uc $2;
      if ($allowed_columns{$lc}) {
        push @$column_names, $lc;
        $ORG_NAME->{  $uc } = $lc;
        $functions->{ $uc } = $functions{'default'};
        $aliases->{   $uc } = $alias ? $alias : $lc;
      } else {
        $$errstr = "Unknown column name '$2'";
        return;
      }
    }
  }

  1;
}

1;

__END__