view release on metacpan or  search on metacpan

lib/Image/DS9/PConsts.pm  view on Meta::CPAN

package Image::DS9::PConsts;

# ABSTRACT: Internal Constants

use v5.10;

use strict;
use warnings;
use overload ();

use Data::Visitor::Tiny ();
use Ref::Util qw( is_regexpref is_coderef is_blessed_ref is_ref is_arrayref is_refref is_scalarref);
use Scalar::Util 'reftype';

our $VERSION = 'v1.0.1';

use Types::TypeTiny 'is_StringLike';

use Image::DS9::Util 'is_TODO';

use Image::DS9::Constants::V1
  'COLORS',
  'FRAME_COORD_SYSTEMS',
  'FRAME_COORD_SYSTEMS_NON_WCS',
  'SKY_COORD_SYSTEMS',
  'ANGULAR_UNITS',
  'ANGULAR_FORMATS',
  'WCS';

use parent 'Exporter';
use Safe::Isa;

## no critic (Modules::ProhibitAutomaticExportation)
our @EXPORT = qw(
  %TypeCvt

  T_ANGLE_UNIT
  T_ARRAY
  T_BOOL
  T_COLOR
  T_COORD
  T_COORDSYS
  T_COORDSYS_NON_WCS
  T_EPHEMERAL
  T_FALSE
  T_FLOAT
  T_HASH
  T_INT
  T_JPEG_FILE
  T_OTHER
  T_PDL
  T_REWRITE
  T_SEXAGESIMAL_DEC
  T_SEXAGESIMAL_RA
  T_SKYFORMAT
  T_SKYFRAME
  T_STRING
  T_STRING_NL
  T_STRING_QUOTE
  T_STRING_STRIP
  T_TIFF_FILE
  T_WCSS
  T_WCS_ARRAY
  T_WCS_HASH
  T_WCS_SCALARREF

  ANGLE_UNIT
  BOOL
  BOOL_FALSE
  COLOR
  COORDSYS
  COORDSYS_NON_WCS

lib/Image/DS9/PConsts.pm  view on Meta::CPAN

our $FALSE;

BEGIN {

    $FLOAT           = qr/[+-]?(?:\d+[.]?\d*|[.]\d+)(?:[eE][+-]?\d+)?/;
    $SEXAGESIMAL_DEC = qr/[+-]?\d{2}:\d{2}:\d{2}(?:.\d+)?/;
    $SEXAGESIMAL_RA  = qr/\d{2}:\d{2}:\d{2}(?:.\d+)?/;

    $TRUE  = qr/1|yes|true/i;
    $FALSE = qr/0|no|false/i;
}


use enum qw( CvtSet CvtGet );

# mustn't be 0
use enum (
    ':T_=1',
    'ANGLE_UNIT',
    'ARRAY',
    'BOOL',
    'COLOR',
    'COORD',
    'COORDSYS',
    'COORDSYS_NON_WCS',
    'EPHEMERAL',
    'FALSE',
    'FLOAT',
    'HASH',
    'INT',
    'JPEG_FILE',
    'OTHER',
    'PDL',
    'REWRITE',
    'SCALARREF',
    'SEXAGESIMAL_DEC',
    'SEXAGESIMAL_RA',
    'SKYFORMAT',
    'SKYFRAME',
    'STRING',
    'STRING_NL',       # trailing \n added on output if necessary
    'STRING_QUOTE',    # wrap string with quote chars
    'STRING_STRIP',    # strip blanks from string on set
    'TIFF_FILE',
    'WCSARRAY',
    'WCSHASH',
    'WCSS',
    'WCS_SCALARREF',
);

## no critic (Modules::ProhibitMultiplePackages)
## no critic (ClassHierarchies::ProhibitExplicitISA)

# These should be split out, but at the moment they require constants
# from Pconsts, and the tokens are defined in Pconsts, so there's a
# circular import loop.

{
    package    #
      Image::DS9::Parser::Token;
    use Ref::Util ();
    sub new {
        my ( $class, %fields ) = @_;

        unless ( Ref::Util::is_ref( $fields{check} ) ) {
            my $check = $fields{check};
            $fields{check} = sub { $_[0] eq $check ? \$_[0] : undef };
        }
        return bless \%fields, $class;
    }
    sub check {
        $_[0]{check}->( $_[1] );
    }

    sub extra { $_[0]{extra} }
    sub name  { $_[0]{name} }
    sub tag   { $_[0]{tag} }
    sub value { $_[0]{value} }
    sub desc  { $_[0]{desc} }

    sub to_string {
        my $self = shift;
        die sprintf( q{%s (%s) didn't implement 'to_string'}, Scalar::Util::blessed( $self ), $self->name );
    }

    sub is_ephemeral { $_[0]{tag} eq Image::DS9::PConsts::T_EPHEMERAL }
    sub is_rewrite   { $_[0]{tag} eq Image::DS9::PConsts::T_REWRITE }


    sub cvt_from_get {
        my $self = shift;
        die unless @_;

        my $valref = shift;
        return Image::DS9::PConsts::type_cvt( Image::DS9::PConsts::CvtGet, $self->tag, $valref );
    }

    sub cvt_for_set {
        my $self = shift;
        die unless @_;

        my $valref = shift;
        return Image::DS9::PConsts::type_cvt( Image::DS9::PConsts::CvtSet, $self->tag, $valref );
    }

    sub _arg_names {
        return ( 'name', 'value', 'tag', 'desc' );
    }


    sub _extract_args {
        my ( $class, $args ) = @_;

        my %args = map { $_ => delete $args->{$_} } $class->_arg_names;

        if ( keys %$args ) {
            require Data::Dump;
            die(
                sprintf(
                    q{%s doesn't support extra args: %s\n%s},
                    $class,
                    Data::Dump::pp( [%$args] ),
                    Data::Dump::pp( [ \%args ] ),
                ) );
        }

        my @missing = grep !exists $args{$_}, keys %args;
        die( 'missing args: ' . join( ', ', @missing ) ) if @missing;

        return %args;
    }

}


{
    package    #
      Image::DS9::Parser::Token::Enum;

    our @ISA = ( 'Image::DS9::Parser::Token' );

    sub new {
        my ( $class, %args ) = @_;

        $args{name} //= 'ENUM';
        %args = $class->_extract_args( \%args );

        die( 'value must be an arrayref' ) unless Ref::Util::is_arrayref( $args{value} );

        my $check = join( q{|}, q{}, ( map { lc $_ } @{ $args{value} } ), q{} );

        return $class->SUPER::new(
            %args,
            check => sub {
                index( $check, q{|} . lc( $_[0] ) . q{|} ) > -1 ? \$_[0] : undef;
            },
        );
    }

    sub to_string {
        my $self = shift;
        return '( ' . join( ' | ', map { "'$_'" } sort @{ $self->value } ) . ' )';
    }

}

{
    package    #
      Image::DS9::Parser::Token::Regexp;

    our @ISA = ( 'Image::DS9::Parser::Token' );

    sub new {
        my ( $class, %args ) = @_;

        %args = $class->_extract_args( \%args );
        my $qr = delete $args{value};

        $qr = qr/^(?:$qr)$/;

        return $class->SUPER::new(
            %args,
            value => $qr,
            check => sub { $_[0] =~ $qr ? \$_[0] : undef },
        );

    }

    sub to_string {
        my $self = shift;
        return q{} . $self->value;
    }

}

{
    package    #
      Image::DS9::Parser::Token::Constant;

    our @ISA = ( 'Image::DS9::Parser::Token' );

    sub new {
        my ( $class, %args ) = @_;

        %args = $class->_extract_args( \%args );

        my $constant = $args{value};
        return $class->SUPER::new( %args, check => sub { $_[0] eq $constant ? \$_[0] : undef }, );