Astro::Catalog::IO::JCMT - JCMT catalogue I/O for Astro::Catalog

  $cat = Astro::Catalog::IO::JCMT->_read_catalog( \@lines );
  $arrref = Astro::Catalog::IO::JCMT->_write_catalog( $cat, %options );
  $filename = Astro::Catalog::IO::JCMT->_default_file();

package Astro::Catalog::IO::JCMT;

use 5.006;
use warnings;
use warnings::register;
use Carp;
use strict;

use Astro::Telescope;
use Astro::Coords;
use Astro::Catalog;
use Astro::Catalog::Star;

use base qw/ Astro::Catalog::IO::ASCII /;

use vars qw/$VERSION $DEBUG /;

$VERSION = '0.16';
$DEBUG   = 0;

# Name must be limited to 15 characters on write
use constant MAX_SRC_LENGTH => 15;

# Default location for a JCMT catalog
my $defaultCatalog = "/local/progs/etc/poi.dat";

# Planets appended to the catalogue
my @PLANETS = qw/ mars uranus saturn jupiter venus neptune /;

sub clean_target_name {
  my $class = shift;
  my $dirty = shift;
  return unless defined $dirty;

  # Remove spaces [compress]
  $dirty =~ s/\s+//g;

  # Remove disallowed characters
  # and replace with dashes
  $dirty =~ s/[,;:'"`]/-/g;

  # Truncate it to the allowed length
  # Name must be limited to MAX_SRC_LENGTH characters
  $dirty = substr($dirty,0,MAX_SRC_LENGTH);

  # Return the cleaned name
  return $dirty;
}

sub _default_file {
  my $class = shift;
  return $ENV{ASTRO_CATALOG_JCMT}
    if (exists $ENV{ASTRO_CATALOG_JCMT} && -e $ENV{ASTRO_CATALOG_JCMT});
  return (-e $defaultCatalog ? $defaultCatalog : () );
}

sub _read_catalog {
  my $class = shift;
  my $lines = shift;

  # Default options
  my %defaults = ( telescope => 'JCMT',
		   incplanets => 1);

  my %options = (%defaults, @_);

  croak "Must supply catalogue contents as a reference to an array"
    unless ref($lines) eq 'ARRAY';

  # Create a new telescope to associate with this 
  my $tel;
  $tel = new Astro::Telescope( $options{telescope} )
    if $options{telescope};

  # Go through each line and parse it
  # and store in the array if we had a successful read
  my @stars = map { $class->_parse_line( $_, $tel); } @$lines;

  # Add planets if required
  if ($options{incplanets}) {
    # create coordinate objects for the planets
    my @planets = map { new Astro::Coords(planet => $_) } @PLANETS;

    # And associate a telescope
    if ($tel) {
      for (@planets) {
	$_->telescope($tel);
      }
    }

    # And create the star objects
    push(@stars, map { new Astro::Catalog::Star( 
						field => 'JCMT',
						id => $_->name,
						coords => $_,
						comment => 'Added automatically',
					       ) } @planets);

  }

  # Create the catalog object
  return new Astro::Catalog( Stars => \@stars,
			     Origin => 'JCMT',
			   );

}

sub _write_catalog {
  my $class = shift;
  my $cat = shift;

  # Would make more sense to use the array ref here
  my @sources = $cat->stars;

  # Counter for unknown targets
  my $unk = 1;

  # Hash for storing target information
  # so that we can search for duplicates
  my %targets;

  # Create hash of all unique target names present
  # after cleaning. We need this so that we can make sure
  # a generated name derived from a duplication (with target mismatch)
  # does not generate a name that already existed explicitly.
  my %allnames = map { $class->clean_target_name($_->coords->name), undef } 
                      @sources;

  # Loop over each source and extract catalog information
  # Make sure that we remove unique entries
  # BUT THAT WE RETAIN THE ORDER OF THE SOURCES IN THE CATALOG
  # Hence an array for the information
  my @processed;
  for my $star (@sources) {

    # Extract the coordinate object
    my $src = $star->coords;

    # Get the name but do not deal with undef yet
    # in case the type is not valid
    my $name = $src->name;

    # Somewhere to store the extracted information
    my %srcdata;

    # Store the name (stripped of spaces) and
    # treat srcdata{name} as the primary name from here on
    $srcdata{name} = $class->clean_target_name( $name );

    # Store a comment
    $srcdata{comment} = $star->comment;

    # prepopulate the default velocity settings
    $srcdata{rv}    = 'n/a';
    $srcdata{vdefn}  = 'RADIO';
    $srcdata{vframe} = 'LSR';

    # Get the type of source
    my $type = $src->type;
    if ($type eq 'RADEC') {
      $srcdata{system} = "RJ";

      # Need to get the space separated RA/Dec and the sign
      $srcdata{long} = $src->ra(format => 'array');
      $srcdata{lat} = $src->dec(format => 'array');

      # Get the velocity information
      my $rv = $src->rv;
      if ($rv) {
	$srcdata{rv}    = $rv;
	$srcdata{vdefn}  = $src->vdefn;
	$srcdata{vframe} = $src->vframe;

	# JCMT compatibility
	$srcdata{vframe} = "LSR" if $srcdata{vframe} eq 'LSRK';

      }

    } elsif ($type eq 'PLANET') {
      # Planets are not supported in catalog form. Skip them
      next;

    } elsif ($type eq 'FIXED') {
      $srcdata{system} = "AZ";

      $srcdata{long} = $src->az(format => 'array');
      $srcdata{lat} = $src->el(format => 'array');

      # Need to remove + sign from long/AZ since we are not expecting
      # it in RA/DEC. This is probably a bug in Astro::Coords
      shift(@{ $srcdata{long} } ) if $srcdata{long}->[0] eq '+';

    } else {
      my $errname = ( defined $srcdata{name} ? $srcdata{name} : "<undefined>");
      warnings::warnif "Coordinate of type $type for target $errname not supported in JCMT catalog files\n";
      next;
    }

    # Generate a name if not defined
    if (!defined $srcdata{name}) {
      $srcdata{name} = "UNKNOWN$unk";
      $unk++;
    }

    # See if we already have this source and that it is really the
    # same source Note that we do not see whether this name is the
    # same as one of the derived names. Eg if CRL618 is in the
    # pointing catalogue 3 times with identical coords and we add a
    # new CRL618 with different coords then we trigger 3 warning
    # messages rather than 1 because we do not check that CRL618_2 is
    # the same as CRL618_1

    # Note that velocity specification is included in this comparison

    if (exists $targets{$srcdata{name}}) {
      my $previous = $targets{$srcdata{name}};

      # Create stringified form of previous coordinate with same name
      # and current coordinate
      my $prevcoords = join(" ",@{$previous->{long}},@{$previous->{lat}},
			    $previous->{rv}, $previous->{vdefn}, $previous->{vframe});
      my $curcoords = join(" ",@{$srcdata{long}},@{$srcdata{lat}},
			    $srcdata{rv}, $srcdata{vdefn}, $srcdata{vframe});

      if ($prevcoords eq $curcoords) {
	# This is the same target so we can ignore it
      } else {
	# Make up a new name. Use the unknown counter for this since we probably
	# have not used it before. Probably not the best approach and might have
	# problems in edge cases but good enough for now
	my $oldname = $srcdata{name};

	# loop for 100 times
	my $count;
	while (1) {
	  # protection loop
	  $count++;

	  # Try to construct a new name based on a global counter
	  # rather than a counter that starts at 1 for each root
	  my $suffix = "_$unk";

	  # increment $unk for next try
	  $unk++;

	  # Abort if we have gone round too many times
	  # Making sure that $unk is incremented first
	  if ($count > 100) {
	    $srcdata{name} = substr($oldname,0,int(MAX_SRC_LENGTH/2)) . 
	        int(rand(10000)+1000);
	    warn "Uncontrollable looping (or unfeasibly large number of duplicate sources with different coordinates). Panicked and generated random source name of $srcdata{name}.\n";
	    last;
	  }

	  # Assume the old name will do fine
	  my $root = $oldname;

	  # Do not want to truncate the _XX off the end later on
	  if (length($oldname) > MAX_SRC_LENGTH - length($suffix)) {
	    # This may well be confusing but we have no choice. Since _XX
	    # is unique the only time we will get a name clash by simply chopping
	    # the string is if we have a duplicate that is too long along with a
	    # target name that includes _XX amd matches the truncated source name!
	    $root = substr($oldname, 0, (MAX_SRC_LENGTH-length($suffix)) );

	  }

	  # Form the new name
	  my $newname = $root . $suffix;

	  # check to see if this name is in the existing target list
	  next if exists $allnames{$newname};

	  # Store it in the targets array and exit loop
	  $srcdata{name} = $newname;
	  last;
	}

	# different target
	warn "Found target with the same name [$oldname] but with different coordinates, renaming it to $srcdata{name}!\n";

	$targets{$srcdata{name}} = \%srcdata;

	# Store it in the array
	push(@processed, \%srcdata);

      }

    } else {
      # Store in hash for easy lookup for duplicates
      $targets{$srcdata{name}} = \%srcdata;

      # Store it in the array
      push(@processed, \%srcdata);

    }

  }


  # Output array for new catalog lines
  my @lines;

  # Write a header
  push @lines, "*\n";
  push @lines, "* Catalog written automatically by class ". __PACKAGE__ ."\n";
  push @lines, "* on date " . gmtime . "UT\n";
  push @lines, "* Origin of catalogue: ". $cat->origin ."\n";
  push @lines, "*\n";

  # Now need to go through the targets and write them to disk
  for my $src (@processed) {
    my $name    = $src->{name};
    my $long    = $src->{long};
    my $lat     = $src->{lat};
    my $system  = $src->{system};
    my $comment = $src->{comment};
    my $rv      = $src->{rv};
    my $vdefn   = $src->{vdefn};
    my $vframe  = $src->{vframe};

    $comment = '' unless defined $comment;

    # Velocity can not easily be done with a sprintf since it can be either
    # a string or a 2 column number
    if (lc($rv) eq 'n/a') {
      $rv = '  n/a  ';
    } else {
      my $sign = ( $rv >= 0 ? '+' : '-' );
      my $val  = $rv;
      $val =~ s/^\s*[+-]\s*//;
      $val =~ s/\s*$//;
      $rv = $sign . ' '. sprintf('%6.1f',$val);
    }

    # Name must be limited to MAX_SRC_LENGTH characters
    # [this should be taken care of by clean_target_name but
    # if we have appended _X....
    $name = substr($name,0,MAX_SRC_LENGTH);

    push @lines, 
      sprintf("%-". MAX_SRC_LENGTH.
      "s    %02d %02d %06.3f %1s %02d %02d %04.1f  %2s  %s  n/a   n/a   %-4s %s %s\n",
      $name, @$long, @$lat, $system, $rv, $vframe, $vdefn, $comment);

  }

  return \@lines;
}

sub _parse_line {
  my $class = shift;
  my $line = shift;
  my $tel = shift;
  chomp $line;

  # Skip commented and blank lines
  return if ($line =~ /^\s*[\*\%]/);
  return if ($line =~ /^\s*$/);

  # Use a pattern match parser
  my @match = ( $line =~ m/^(.*?)  # Target name (non greedy)
		          		          \s*   # optional trailing space
                                                    (\d{1,2}) # 1 or 2 digits [RA:h] [greedy]
		          		          \s+       # separator
		          		          (\d{1,2}) # 1 or 2 digits [RA:m]
		          		          \s+       # separator
		          		          (\d{1,2}(?:\.\d*)?) # 1|2 digits opt .fraction [RA:s]
		                    		                    # no capture on fraction
		          		          \s+
		          		          ([+-]?\s*\d{1,2}) # 1|2 digit [dec:d] inc sign
		          		          \s+
		          		          (\d{1,2}) # 1|2 digit [dec:m]
		          		          \s+
		          		          (\d{1,2}(?:\.\d*)?) # arcsecond (optional fraction)
                                                                                            # no capture on fraction
		          		          \s+
		          		          (RJ|RB|GA|AZ) # coordinate type
		         		         # most everything else is optional
		         		         # [sign]velocity, flux,vrange,vel_def,frame,comments
		         		         \s*
		         		         (n\/a|[+-]\s*\d+(?:\.\d*)?)?  # velocity [8]
		         		         \s*
		         		         (n\/a|\d+(?:\.\d*)?)?    # flux [9]
		         		         \s*
		         		         (n\/a|\d+(?:\.\d*)?)?    # vel range [10]
		         		         \s*
		         		         ([\w\/]+)?               # vel frame [11]
		         		         \s*
		         		         ([\w\/]+)?               # vel defn [12]
		         		         \s*
		         		         (.*)$                    # comment [13]
				/xi);

  # Abort if we do not have matches for the first 8 fields
  for (0..7) {
    return unless defined $match[$_];
  }

  # Read the values
  my $target = $match[0];
  my $ra = join(":",@match[1..3]);
  my $dec = join(":",@match[4..6]);
  $dec =~ s/\s//g; # remove  space between the sign and number
  my $epoc = $match[7];

  print "Creating a new source in _parse_line: $target\n" if $DEBUG;

  # need to translate JCMT epoch to normal epoch
  my %coords;
  $epoc = uc($epoc);
  $coords{name} = $target;
  if ($epoc eq 'RJ') {
    $coords{ra} = $ra;
    $coords{dec} = $dec;
    $coords{type} = "j2000"
  } elsif ($epoc eq 'RB') {
    $coords{ra} = $ra;
    $coords{dec} = $dec;
    $coords{type} = "b1950";
  } elsif ($epoc eq 'GA') {
    $coords{long} = $ra;
    $coords{lat}  = $dec;
    $coords{type} = "galactic";
  } elsif ($epoc eq 'AZ') {
    $coords{az}   = $ra;
    $coords{el}   = $dec;
    $coords{units} = 'sexagesimal';
  } else {
    warnings::warnif "Unknown coordinate type: '$epoc' for target $target. Ignoring line.";
    return;
  }

  # Read the flux as a comment
  my $fcol = 9;  # flux column
  my $ccol = 13; # comment column

  my $flux = (defined $match[$fcol] ? $match[$fcol] : '');
  $flux = '' if $flux =~ /n\/a/i;

  # catalog comments are space delimited
  my $cat_comm = (defined $match[$ccol] ? $match[$ccol] : '');
  my $comment = $flux;
  $comment .= " $cat_comm" if $cat_comm;

  # Replace multiple spaces in comment with single space
  $comment =~ s/\s+/ /g;

  # velocity
  $coords{vdefn} = "RADIO";
  $coords{vframe} = "LSR";
  if ($match[8] !~ /n/) {
    $match[8] =~ s/\s//g; # remove spaces
    $coords{rv} = $match[8];
    $coords{vdefn} = $match[12];
    $coords{vframe} = $match[11];
  }

  # create the source object
  my $source = new Astro::Coords( %coords );

  unless (defined $source ) {
    if ($DEBUG) {
      print "failed to create source for '$target' and $ra and $dec and $epoc\n";
      return;
    } else {
      croak "Error parsing line. Unable to create source date for target '$target' at RA '$ra' Dec '$dec' and Epoch '$epoc'\n";
    }
  }

  $source->telescope( $tel ) if $tel;
  $source->comment($comment);

  # Field name should simply be linked to the telescope
  my $field = (defined $tel ? $tel->name : '<UNKNOWN>' );

  print "Created a new source in _parse_line: $target in field $field\n" if $DEBUG;

  # Now create the star object
  return new Astro::Catalog::Star( id => $target,
				   coords => $source,
				   field => $field,
				   comment => $comment,
				 );

}

1;