use utf8;
use strict;
use warnings;

package Number::Phone::FR;

# $VERSION is limited to 2 digits after the dot
# Other digits are reserved for ARCEP data versonning
# in Number::Phone::FR::Full
our $VERSION = '0.07';

use Number::Phone;
use parent 'Number::Phone';

use Carp;
use Scalar::Util 'blessed';

my %pkg2impl;

# Select the implementation to use via "use Number::Phone::FR"

sub import
{
    my $class = shift;
    croak "invalid sub-class" unless $class->isa(__PACKAGE__);
    if ($class eq __PACKAGE__) {
        if (@_) {
            $class = $_[0];
            $class =~ s/^:?(.)/\U$1/;
            substr($class, 0, 0) = __PACKAGE__.'::';

            my $level = 0;
            my $pkg;
            while (($pkg = (caller $level)[0]) =~ /^Number::Phone(?:::|$)/) {
                $level++;
            }
            $pkg2impl{$pkg} = $class;

            # Load the class
            eval "require $class; 1" or croak "$@\n";
            $class->isa(__PACKAGE__) or croak "$class is not a valid class";
        }
    } else {
        #croak "unexpected arguments for import" if @_;
        my $pkg = (caller)[0];
        croak "$class is private" unless $pkg =~ m/^Number::Phone(?:::|$)/;
        $pkg2impl{$pkg} = $class;
    }
}

#END {
#    foreach (sort keys %pkg2impl) {
#        print STDERR "# $_ => $pkg2impl{$_}\n";
#    }
#}


# Select the implementation based on $pkg2impl
sub _get_class
{
    my ($class) = @_;
    return $class if defined $class && $class ne __PACKAGE__;
    my $level = 0;
    my ($pkg, $impl);
    while ($pkg = (caller $level)[0]) {
        $impl = $pkg2impl{$pkg};
        return $impl if defined $impl;
        $level++;
    }
    # Default implementation
    return __PACKAGE__;
}


use constant RE_SUBSCRIBER =>
  qr{
    \A
    (?:
       \+33          # Préfixe international (+33 numéro)
     | (?:3651)?
       (?:
         [04789]     # Transporteur par défaut (0) ou Sélection du transporteur
       | 16 [0-9]{2} # Sélection du transporteur
       ) (?:033)?    # Préfixe international (0033 numéro)
    ) ([1-9][0-9]{8})  # Numéro de ligne
    \z
  }xs;

use constant RE_FULL =>
  qr{
  \A (?:
    1 (?:
        0[0-9]{2}  # Opérateur
      | 5          # SAMU
      | 7          # Police/gendarmerie
      | 8          # Pompiers
      | 1 (?:
            2      # Numéro d'urgence européen
          | 5      # Urgences sociales
	  | 6000          # 116000 : Enfance maltraitée
          | 8[0-9]{3}     # 118XYZ : Renseignements téléphoniques
	  | 9      # Enfance maltraitée
	  )
      )
  | 3[0-9]{3}
  | (?:
       \+33          # Préfixe international (+33 numéro)
     | (?:3651)?     # Préfixe d'anonymisation
       (?:
         [04789]     # Transporteur par défaut (0) ou Sélection du transporteur
       | 16 [0-9]{2} # Sélection du transporteur
       ) (?:033)?    # Préfixe international (0033 numéro)
    ) [1-9][0-9]{8}  # Numéro de ligne
  ) \z
  }xs;




sub country_code() { 33 }

# Number::Phone's implementation of country() does not yet allow
# clean subclassing so we explicitely implement it here
sub country() { 'FR' }


sub new
{
    my $class = shift;
    my $number = shift;
    $class = ref $class if ref $class;

    $class = _get_class($class);

    croak "No number given to ".__PACKAGE__."->new()\n" unless defined $number;
    croak "Invalid phone number (scalar expected)" if ref $number;

    my $num = $number;
    $num =~ s/[^+0-9]//g;
    return Number::Phone->new("+$1") if $num =~ /\A(?:\+|00)((?:[^3]|3[^3]).*)\z/;

    return is_valid($number) ? bless(\$num, $class) : undef;
}


sub is_valid
{
    my ($number) = (@_);
    return 1 if blessed($number) && $number->isa(__PACKAGE__);

    my $class = _get_class();
    return $number =~ $class->RE_FULL;
}


sub is_allocated
{
    undef
}

sub is_in_use
{
    undef
}

sub _num(\@)
{
    my $args = shift;
    my $num = shift @$args;
    my $class = ref $num;
    if ($class) {
	$num = ${$num};
    } else {
	$class = _get_class();
	$num = shift @$args;
    }
    return ($class, $num);
}

# Vérifie les chiffres du numéro de ligne
# Les numéros spéciaux ne matchent pas
sub _check_line
{
    my ($class, $num) = _num(@_);
    my @matches = ($num =~ $class->RE_SUBSCRIBER);
    return 0 unless @matches;
    my $line = (grep { defined } @matches)[0];
    return 1 if $line =~ shift;
    undef
}

sub is_geographic
{
    return _check_line(@_, qr/\A[1-5].{8}\z/)
}

sub is_fixed_line
{
    return _check_line(@_, qr/\A[1-5].{8}\z/)
}

sub is_mobile
{
    return _check_line(@_, qr/\A[67].{8}\z/)
}

sub is_pager
{
    undef
}

sub is_ipphone
{
    return _check_line(@_, qr/\A9/)
}

sub is_isdn
{
    undef
}

sub is_tollfree
{
    #return 1 
    # FIXME Gérer les préfixes
    return 0 unless $_[1] =~ /\A08[0-9]{8}\z/;
    undef
}

sub is_specialrate
{
    # FIXME Gérer les préfixes
    return 0 unless $_[1] =~ /\A08[0-9]{8}\z/;
    1
}

sub is_adult
{
    return 0 unless _check_line(@_, qr/\A8/);
    undef
}

sub is_personal
{
    undef
}

sub is_corporate
{
    undef
}

sub is_government
{
    undef
}

sub is_international
{
    undef
}

sub is_network_service
{
    my ($class, $num) = _num(@_);
    # Les services réseau sont en direct : jamais de préfixe
    ($num =~ /\A1(?:|[578]|0[0-9]{2}|1(?:[259]|6000|8[0-9]{3}))\z/) ? 1 : 0
}

sub areacode
{
    undef
}

sub areaname
{
    undef
}

sub location
{
    undef
}

sub subscriber
{
    my ($class, $num) = _num(@_);
    my @m = ($num =~ $class->RE_SUBSCRIBER);
    return undef unless @m;
    @m = grep { defined } @m;
    $m[0];
}

my %length_to_format = (
    # 2 => as is
    4 => sub { s/\A(..)(..)/$1 $2/ },
    6 => sub { s/\A(...)(...)/$1 $2/ },
    10 => sub { s/(\d\d)(?=.)/$1 /g },
    13 => sub {
	       s/\A(00)(33)(.)(..)(..)(..)(..)\z/+$2 $3 $4 $5 $6 $7/
	    || s/\A(....)(.)(..)(..)(..)(..)\z/+33 $1 $2 $3 $4 $5 $6/
	  },
    14 => sub { s/\A(....)(..)(..)(..)(..)(..)\z/$1 $2 $3 $4 $5 $6/ },
    12 => sub { s/\A(\+33)(.)(..)(..)(..)(..)\z/$1 $2 $3 $4 $5 $6/ },
    16 => sub { s/\A(\+33)(....)(.)(..)(..)(..)(..)\z/$1 $2 $3 $4 $5 $6 $7/ },
);

sub format
{
    my ($class, $num) = _num(@_);
    my $l = length $num;
    my $fmt = $length_to_format{$l};
    return defined $fmt
	?   do {
		local $_ = $num;
		$fmt->();
		$_;
	    }
	: $num;
}



package Number::Phone::FR::Simple;

use parent 'Number::Phone::FR';

BEGIN {
    $INC{'Number/Phone/FR/Simple.pm'} = __FILE__;
}

1;
__END__
=head1 NAME

Number::Phone::FR - Phone number information for France (+33)

=head1 SYNOPSIS

Use C<Number::Phone::FR> through C<L<Number::Phone>>:

    use Number::Phone;
    my $num = Number::Phone->new('+33148901515');

Select a particular implementation of C<Number::Phone::FR> for this package:

    use Number::Phone::FR 'Full';
    my $num = Number::Phone->new('+33148901515');

    use Number::Phone::FR 'Simple';
    my $num = Number::Phone->new('+33148901515');

One-liners:

    perl -MNumber::Phone "-Esay Number::Phone->new(q!+33148901515!)->format"
    perl -MNumber::Phone::FR=Full "-Esay Number::Phone->new(q!+33148901515!)->operator"
    perl -MNumber::Phone::FR=Full "-Esay Number::Phone::FR->new(q!3949!)->operator"

=head1 DESCRIPTION

This is a subclass of L<Number::Phone> that provides information for phone
numbers in France.

I<B<Note:> Cette documentation est E<eacute>galement disponible en
franE<ccedil>ais dans L<POD2::FR::Number::Phone::FR>.>

Two implementations are provided:

=over 4

=item *

C<Simple>

=item *

C<Full>: a more complete implementation that does checks based on information
from the ARCEP.

=back

The implementation is selected for a particular package by importing the
Number::Phone::FR package with the selected implementation.
All Number::Phone::FR objects created from this package (either indirectly
with Number::Phone->new or explicitely with Number::Phone::FR->new) will be
created using this implementation.

=head1 DATA SOURCES

L<http://www.arcep.fr/index.php?id=8992>

It looks like ARCEP publishes updates about twice a month.

The tools for rebuilding the Number-Phone-FR CPAN distribution with updated
data are included in the distribution:

    perl Build.PL
    ./Build update
    perl Build.PL
    ./Build
    ./Build test
    ./Build dist

=head1 VERSIONNING

The C<Number-Phone-FR> distribution contains different modules which have
their own versions:

=over 4

=item *

Number::Phone::FR : C<m.nn> (I<major> . I<minor>)

=item *

L<Number::Phone::FR::Full> : C<m.nnyyddd> (I<major> . I<minor> I<year> I<day-of-year>)

=back

C<m.nn> is the versionning of the code. Common for the two packages.

C<yyddd> is the versionning of the ARCEP data.

=head1 SEE ALSO

=over 4

=item *

L<http://fr.wikipedia.org/wiki/Plan_de_num%C3%A9rotation_t%C3%A9l%C3%A9phonique_en_France>

=item *

L<Number::Phone>

=back

=head1 SUPPORT

(english or french)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Number-Phone-FR>

The latest available source code (work in progress) is published on GitHub:
L<https://github.com/dolmen/p5-Number-Phone-FR>

=head1 AUTHOR

Olivier MenguE<eacute>, L<mailto:dolmen@cpan.org>

=head1 COPYRIGHT AND LICENSE

Copyright E<copy> 2010-2011 Olivier MenguE<eacute>.

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

=cut