package Perldoc::Server::Model::Section;

use strict;
use warnings;
use 5.010;
use parent 'Catalyst::Model';

use Memoize;
memoize('pages', NORMALIZER => sub { $_[1] });

our @section_data = (
  { 
    id    => 'overview',
    name  => 'Overview',
    pages => [qw/perl perlintro perlrun perlbook perlcommunity/] 
  },
  {
    id    => 'tutorials',
    name  => 'Tutorials',
    pages => [qw/perlreftut perldsc perllol perlrequick 
                 perlretut perlboot perltoot perltooc perlbot
                 perlstyle perlcheat perltrap perldebtut
                 perlopentut perlpacktut perlthrtut perlothrtut
                 perlxstut perlunitut perlpragma/]
  },
  {
    id    => 'language',
    name  => 'Language reference',
    pages => [qw/perlsyn perldata perlsub perlop
                 perlfunc perlpod perlpodspec perldiag
                 perllexwarn perldebug perlvar perlre perlrecharclass perlrebackslash
                 perlreref perlref perlform perlobj perltie
                 perldbmfilter perlipc perlfork perlnumber
                 perlport perllocale perluniintro perlunicode
                 perlebcdic perlsec perlmod perlmodlib
                 perlmodstyle perlmodinstall perlnewmod
                 perlcompile perlfilter perlglossary CORE
                 /]
  },
  {
    id    => 'internals',
    name  => 'Internals and C language interface',
    pages => [qw/perlembed perldebguts perlxs perlxstut
                 perlclib perlguts perlcall perlapi perlintern
                 perliol perlapio perlhack perlreguts perlreapi/]
  },
  {
    id    => 'licence',
    name  => 'Licence',
    pages => [qw/perlartistic perlgpl/]
  },
  {
    id    => 'platforms',
    name  => 'Platform specific',
    pages => [qw/perlaix perlamiga perlapollo perlbeos perlbs2000
                 perlce perlcygwin perldgux perldos perlepoc
                 perlfreebsd perlhpux perlhurd perlirix perllinux
                 perlmachten perlmacos perlmacosx perlmint perlmpeix
                 perlnetware perlopenbsd perlos2 perlos390 perlos400
                 perlplan9 perlqnx perlriscos perlsolaris perlsymbian perltru64 perluts
                 perlvmesa perlvms perlvos perlwin32/]
  },
#  { 
#    id        => 'pragmas',
#    name      => 'Pragmas',
#    pages     => [qw/attributes attrs autouse base bigint bignum 
#                     bigrat blib bytes charnames constant diagnostics
#                     encoding feature fields filetest if integer less lib
#                     locale mro open ops overload re sigtrap sort strict
#                     subs threads threads::shared utf8 vars vmsish
#                     warnings warnings::register/]
#  },
  {
    id        => 'utilities',
    name      => 'Utilities',
    pages     => [qw/perlutil a2p c2ph config_data corelist cpan cpanp
                     cpan2dist dprofpp enc2xs find2perl h2ph h2xs instmodsh
                     libnetcfg perlbug perlcc piconv prove psed podchecker
                     perldoc perlivp pod2html pod2latex pod2man pod2text
                     pod2usage podselect pstruct ptar ptardiff s2p shasum
                     splain xsubpp perlthanks/]
  },
  {
    id        => 'faq',
    name      => 'FAQs',
    lastpages => [qw/perlunifaq/],
    pagematch => qr/^perlfaq/,
    sort      => sub {$a cmp $b}
  },
  { 
    id        => 'history',
    name      => 'History / Changes',
    pages     => [qw/perlhist perltodo perldelta/],
    pagematch => qr/^perl\d+delta$/,
    sort      => sub {
                   (my $c = $a) =~ s/.*?(\d)(\d+).*/$1.$2/;
                   (my $d = $b) =~ s/.*?(\d)(\d+).*/$1.$2/;
                   $d <=> $c
                 }
  },
);


sub ACCEPT_CONTEXT { 
  my ( $self, $c, @extra_arguments ) = @_; 
  bless { %$self, c => $c }, ref($self); 
}


sub list {
  my $self = shift;
  
  return map {$_->{id}} @section_data;
}


sub name {
  my ($self,$section_id) = @_;
  
  return (map {$_->{name}} (grep {$_->{id} eq $section_id} @section_data))[0];
}


sub pages {
  my ($self, $section_id) = @_;
  
 foreach my $section (@section_data) {
    next unless ($section->{id} eq $section_id);
    my @pages;
    
    if ($section->{pages}) {
      push @pages,@{$section->{pages}};
    }
    
    if ($section->{pagematch}) {
      my @matched_pages = grep {$_ =~ $section->{pagematch}} $self->{c}->model('Index')->find_modules;
      if (my $sortsub = $section->{sort}) {
        @matched_pages = sort $sortsub @matched_pages;
      }
      push @pages, @matched_pages;
    }
    
    if ($section->{lastpages}) {
      push @pages,@{$section->{lastpages}};
    }
    
    return @pages;
  }
}


sub exists {
  my ($self, $section_id) = @_;
  
  foreach my $section (@section_data) {
    return 1 if ($section->{id} eq $section_id);
  }
  
  return undef;
}

=head1 NAME

Perldoc::Server::Model::Section - Catalyst Model

=head1 DESCRIPTION

Catalyst Model.

=head1 AUTHOR

Jon Allen

=head1 LICENSE

This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;