/usr/local/CPAN/Image-DS9/Image/DS9/PConsts.pm
package Image::DS9::PConsts;
use strict;
use warnings;
require Exporter;
our @ISA = qw( Exporter );
our @EXPORT =
qw(
%TypeCvt
T_FLOAT
T_INT
T_BOOL
T_COORD
T_WCSS
T_COORDSYS
T_SKYFRAME
T_SKYFORMAT
T_SEXAGESIMAL_RA
T_SEXAGESIMAL_DEC
T_COLOR
T_ARRAY
T_HASH
T_WCS_HASH
T_WCS_ARRAY
T_WCS_SCALARREF
T_PDL
T_OTHER
T_EPHEMERAL
T_REWRITE
T_STRING
T_STRING_STRIP
T_STRING_NL
BOOL
FLOAT
INT
STRING
STRING_STRIP
STRING_NL
HASH
PDL
SEXAGESIMAL_RA
SEXAGESIMAL_DEC
COORD_RA
COORD_DEC
WCSS
COORDSYS
SKYFRAME
SKYFORMAT
COLOR
QNONE
QATTR
QARGS
QONLY
QYES
WCS_HASH
WCS_ARRAY
WCS_SCALARREF
SCALARREF
type_cvt
CvtSet
CvtGet
ENUM
ARRAY
EPHEMERAL
REWRITE
);
our $FLOAT;
our $SEXAGESIMAL_RA;
our $SEXAGESIMAL_DEC;
our $WCSS;
our $TRUE;
our $FALSE;
BEGIN {
sub ENUM { my $pat = join( '|', @_ ); qr/^($pat)$/i };
$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+)?/;
$WCSS = ENUM('wcs', map { 'wcs' . $_ } ('a'..'z'));
$TRUE = qr/1|yes|true/i;
$FALSE = qr/0|no|false/i;
};
use constant CvtSet => 0;
use constant CvtGet => 1;
# mustn't be 0
use constant T_FLOAT => 1;
use constant T_INT => 2;
use constant T_BOOL => 3;
use constant T_COORD => 4;
use constant T_WCSS => 5;
use constant T_COORDSYS => 6;
use constant T_SKYFRAME => 7;
use constant T_SKYFORMAT => 8;
use constant T_COLOR => 10;
use constant T_HASH => 11;
use constant T_STRING => 12;
use constant T_PDL => 13;
use constant T_SCALARREF => 14;
use constant T_WCSARRAY => 15;
use constant T_WCSHASH => 16;
use constant T_EPHEMERAL => 17;
use constant T_SEXAGESIMAL_RA => 18;
use constant T_SEXAGESIMAL_DEC => 19;
use constant T_REWRITE => 20;
use constant T_STRING_NL => 21; # trailing \n added on output if necessary
use constant T_WCS_SCALARREF => 22;
use constant T_STRING_STRIP => 23; # strip blanks from string on set
use constant T_ARRAY => 1024;
use constant T_OTHER => 8192;
use constant BOOL => [ T_BOOL, qr/$TRUE|$FALSE/ ];
use constant FLOAT => [ T_FLOAT, $FLOAT ];
use constant INT => [ T_INT, qr/[+-]?\d+/ ];
use constant STRING => [ T_STRING, sub { ! ref $_[0] } ];
use constant STRING_STRIP => [ T_STRING_STRIP, sub { ! ref $_[0] } ];
use constant STRING_NL => [ T_STRING_NL, sub { ! ref $_[0] || 'SCALAR' eq ref $_[0] } ];
use constant HASH => [ T_HASH, sub { 'HASH' eq ref $_[0] } ];
use constant SCALARREF => [ T_SCALARREF, sub { ! ref $_[0] || 'SCALAR' eq ref $_[0] } ];
use constant WCS_HASH => [ T_WCSHASH, sub { 'HASH' eq ref $_[0] } ];
use constant WCS_ARRAY => [ T_WCSARRAY, sub { 'ARRAY' eq ref $_[0] } ];
use constant WCS_SCALARREF => [ T_WCS_SCALARREF, sub { ! ref $_[0] || 'SCALAR' eq ref $_[0] } ];
use constant PDL => [ T_PDL, sub { UNIVERSAL::isa( $_[0], 'PDL' ) } ];
use constant SEXAGESIMAL_RA => [ T_SEXAGESIMAL_RA, $SEXAGESIMAL_RA ];
use constant SEXAGESIMAL_DEC => [ T_SEXAGESIMAL_DEC, $SEXAGESIMAL_DEC ];
use constant COORD_RA => [ T_COORD, qr/$FLOAT|$SEXAGESIMAL_RA/ ];
use constant COORD_DEC => [ T_COORD, qr/$FLOAT|$SEXAGESIMAL_DEC/ ];
use constant WCSS => [ T_WCSS, $WCSS ];
use constant COORDSYS => [ T_COORDSYS,
ENUM( qw ( physical image wcs ), $WCSS ) ];
use constant SKYFRAME => [ T_SKYFRAME,
ENUM( qw ( fk4 fk5 icrs galactic ecliptic ) ) ];
use constant SKYFORMAT => [ T_SKYFORMAT, ENUM( qw ( degrees sexagesimal ) ) ];
use constant COLOR => [ T_COLOR, ENUM( qw ( black white red green blue
cyan magenta yellow ) ) ];
# can't do a query; if the arguments aren't present, it's an error
use constant QNONE => 0b0000;
# can do query;
use constant QYES => 0b0001;
# query may have attributes, otherwise must have no attributes
use constant QATTR => 0b0100;
# query only
use constant QONLY => 0b1000;
# query must have the specified args, otherwise must have no args
use constant QARGS => 0b0010 | QONLY;
# it's an array type, with the passed number of elements
sub ARRAY
{
my ( $min, $max ) = @_;
# no args, don't care about size
if ( 0 == @_ )
{
[ T_ARRAY, sub { 'ARRAY' eq ref $_[0] } ]
}
# ($fixed_size)
elsif( 1 == @_ )
{
[ T_ARRAY, sub { 'ARRAY' eq ref $_[0]
&& $min == @{$_[0]}
} ]
}
# (0,$max)
elsif ( 0 == $min )
{
[ T_ARRAY, sub { 'ARRAY' eq ref $_[0]
&& @{$_[0]} <= $max
} ]
}
# ($min, -1) => lower limit only
elsif ( -1 == $max )
{
[ T_ARRAY, sub { 'ARRAY' eq ref $_[0]
&& $min <= @{$_[0]}
} ]
}
# ($min,$max) lower and upper
else
{
[ T_ARRAY, sub { 'ARRAY' eq ref $_[0]
&& $min <= @{$_[0]}
&& @{$_[0]} <= $max
} ]
}
}
sub EPHEMERAL {
[ T_EPHEMERAL, $_[0] ]
}
sub REWRITE {
[ T_REWRITE, $_[0], \( $_[1] ) ]
}
# these must return references! $_[0] is always a reference;
# return $_[0] if no change
our %TypeCvt = (
T_BOOL() => [
# outgoing
sub { \( ${$_[0]} =~ $TRUE ? 'yes' : 'no' ) },
# incoming
sub { \( ${$_[0]} =~ $TRUE ? 1 : 0 ) }
],
T_WCSHASH() => [
# outgoing
sub
{
my $wcs = '';
while( my ($key, $val ) = each %{$_[0]} )
{
# remove blank lines
next if $key eq '';
# aggressively remove surrounding apostrophes
$val =~ s/^'+//;
$val =~ s/'+$//;
# remove unnecessary blanks
$val =~ s/^\s+//;
$val =~ s/\s+$//;
# surround all values with apostrophes
$wcs .= uc( $key ) . ($val ne '' ? " = '$val'\n" : "\n" );
}
$wcs;
}
],
T_WCSARRAY() => [
# outgoing
sub{
$_[0] = \( join( "\n", @{$_[0]}) . "\n" );
${$_[0]} =~ s/^\s+//gm;
${$_[0]} =~ s/^\s*\n//gm;
$_[0];
},
],
T_WCS_SCALARREF() => [
sub {
${$_[0]} =~ s/^\s+//gm;
${$_[0]} =~ s/^\s*\n//gm;
$_[0] = \( ${$_[0]} . "\n" )
unless substr(${$_[0]},-1,1) eq '\n';
$_[0];
}
],
T_ARRAY() => [
# outgoing
undef,
# incoming
sub {
( my $s = ${$_[0]} ) =~ s/^\s+//;
$s =~ s/\s+$//;
$_[0] = [ split( / /, $s ) ];
$_[0];
}
],
T_STRING_NL() => [
sub {
$_[0] = \( ${$_[0]} . "\n" )
unless substr(${$_[0]},-1,1) eq '\n';
$_[0];
}
],
T_STRING_STRIP() => [
sub {
${$_[0]} =~ s/\s+//g;
$_[0];
}
],
);
sub type_cvt
{
my $dir = shift;
my $type = shift;
defined $TypeCvt{$type}[$dir] ? $TypeCvt{$type}[$dir]->($_[0]) :
ref( $_[0] ) ? $_[0] : \( $_[0] );
}
1;