File Coverage

blib/lib/Number/Phone/FR.pm

Criterion	Covered	Total	%
statement	101	123	82.1
branch	25	46	54.3
condition	3	6	50.0
subroutine	23	38	60.5
pod	23	23	100.0
total	175	236	74.1

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.09';

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__