Profile: /wise/base/deliv/dev/lib/perl/FITSIO.pm

File	/wise/base/deliv/dev/lib/perl/FITSIO.pm
Statements Executed	100
Total Time	0.029389 seconds

Subroutines — ordered by exclusive time
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
2	2	1	0.00011	0.00011	FITSIO::	fpre
0	0	0	0	0	FITSIO::	BEGIN
0	0	0	0	0	FITSIO::	DESTROY
0	0	0	0	0	FITSIO::	FITS_close
0	0	0	0	0	FITSIO::	FITS_open
0	0	0	0	0	FITSIO::	__ANON__[:1631]
0	0	0	0	0	FITSIO::	__ANON__[:43]
0	0	0	0	0	FITSIO::	axes
0	0	0	0	0	FITSIO::	bpix2type
0	0	0	0	0	FITSIO::	c_isit
0	0	0	0	0	FITSIO::	c_new
0	0	0	0	0	FITSIO::	c_split
0	0	0	0	0	FITSIO::	cel2pix
0	0	0	0	0	FITSIO::	check_sig
0	0	0	0	0	FITSIO::	ckeytype
0	0	0	0	0	FITSIO::	classify_hdudef
0	0	0	0	0	FITSIO::	cleario
0	0	0	0	0	FITSIO::	close_file
0	0	0	0	0	FITSIO::	coldispname
0	0	0	0	0	FITSIO::	colinfo
0	0	0	0	0	FITSIO::	colix
0	0	0	0	0	FITSIO::	collapse_array
0	0	0	0	0	FITSIO::	colname
0	0	0	0	0	FITSIO::	colnames
0	0	0	0	0	FITSIO::	colnum
0	0	0	0	0	FITSIO::	colnums
0	0	0	0	0	FITSIO::	colsize
0	0	0	0	0	FITSIO::	coltypename
0	0	0	0	0	FITSIO::	commentp
0	0	0	0	0	FITSIO::	create_hdus
0	0	0	0	0	FITSIO::	currhdu
0	0	0	0	0	FITSIO::	dcoltype
0	0	0	0	0	FITSIO::	dcoltypename
0	0	0	0	0	FITSIO::	delcols
0	0	0	0	0	FITSIO::	delete_curr_hdu
0	0	0	0	0	FITSIO::	delete_tbl_cols
0	0	0	0	0	FITSIO::	delete_tbl_rows
0	0	0	0	0	FITSIO::	delrows
0	0	0	0	0	FITSIO::	dkeytype
0	0	0	0	0	FITSIO::	dump_cols
0	0	0	0	0	FITSIO::	dump_hdu
0	0	0	0	0	FITSIO::	dumpcols
0	0	0	0	0	FITSIO::	dumphdu
0	0	0	0	0	FITSIO::	dumphdus
0	0	0	0	0	FITSIO::	elemstr
0	0	0	0	0	FITSIO::	end
0	0	0	0	0	FITSIO::	err_stack
0	0	0	0	0	FITSIO::	err_text
0	0	0	0	0	FITSIO::	file
0	0	0	0	0	FITSIO::	fp
0	0	0	0	0	FITSIO::	from
0	0	0	0	0	FITSIO::	get_all_col_info
0	0	0	0	0	FITSIO::	get_all_keys
0	0	0	0	0	FITSIO::	get_col_info
0	0	0	0	0	FITSIO::	get_col_num
0	0	0	0	0	FITSIO::	get_curr_hdu
0	0	0	0	0	FITSIO::	get_hdr_str
0	0	0	0	0	FITSIO::	get_hdu_meta
0	0	0	0	0	FITSIO::	get_hdu_name
0	0	0	0	0	FITSIO::	get_hdu_offsets
0	0	0	0	0	FITSIO::	get_hdu_type
0	0	0	0	0	FITSIO::	get_im_dim
0	0	0	0	0	FITSIO::	get_im_size
0	0	0	0	0	FITSIO::	get_impix
0	0	0	0	0	FITSIO::	get_num_hdus
0	0	0	0	0	FITSIO::	get_num_keys
0	0	0	0	0	FITSIO::	get_std_args
0	0	0	0	0	FITSIO::	get_std_keys
0	0	0	0	0	FITSIO::	get_tbl_col_packed
0	0	0	0	0	FITSIO::	get_tbl_size
0	0	0	0	0	FITSIO::	get_val_type
0	0	0	0	0	FITSIO::	getbpix
0	0	0	0	0	FITSIO::	gethdu
0	0	0	0	0	FITSIO::	gethdus
0	0	0	0	0	FITSIO::	getoptrows
0	0	0	0	0	FITSIO::	getwcs
0	0	0	0	0	FITSIO::	handle_err
0	0	0	0	0	FITSIO::	hdrstr
0	0	0	0	0	FITSIO::	hdukey
0	0	0	0	0	FITSIO::	hdukeys
0	0	0	0	0	FITSIO::	hdumeta
0	0	0	0	0	FITSIO::	hdun
0	0	0	0	0	FITSIO::	hdunames
0	0	0	0	0	FITSIO::	hdunum
0	0	0	0	0	FITSIO::	hdutype
0	0	0	0	0	FITSIO::	hdutypes
0	0	0	0	0	FITSIO::	imsize
0	0	0	0	0	FITSIO::	imtype
0	0	0	0	0	FITSIO::	ioinfo
0	0	0	0	0	FITSIO::	iostate
0	0	0	0	0	FITSIO::	is_fitsio
0	0	0	0	0	FITSIO::	key
0	0	0	0	0	FITSIO::	keydispname
0	0	0	0	0	FITSIO::	keyhash
0	0	0	0	0	FITSIO::	keytypes
0	0	0	0	0	FITSIO::	lol_c_unbless
0	0	0	0	0	FITSIO::	make_hdu_def_like
0	0	0	0	0	FITSIO::	make_hdudef_std
0	0	0	0	0	FITSIO::	mode
0	0	0	0	0	FITSIO::	move_to_hdu
0	0	0	0	0	FITSIO::	new
0	0	0	0	0	FITSIO::	newhdu
0	0	0	0	0	FITSIO::	nlolels
0	0	0	0	0	FITSIO::	normalize_cols
0	0	0	0	0	FITSIO::	normalize_hdudef
0	0	0	0	0	FITSIO::	nread
0	0	0	0	0	FITSIO::	nrows
0	0	0	0	0	FITSIO::	numhdus
0	0	0	0	0	FITSIO::	nwritten
0	0	0	0	0	FITSIO::	offsets
0	0	0	0	0	FITSIO::	open_file
0	0	0	0	0	FITSIO::	optrows
0	0	0	0	0	FITSIO::	pack_val
0	0	0	0	0	FITSIO::	pcoltype
0	0	0	0	0	FITSIO::	pix2cel
0	0	0	0	0	FITSIO::	pkeytype
0	0	0	0	0	FITSIO::	put_impix
0	0	0	0	0	FITSIO::	read1tblcolbynum
0	0	0	0	0	FITSIO::	read_key
0	0	0	0	0	FITSIO::	readcol
0	0	0	0	0	FITSIO::	readcols
0	0	0	0	0	FITSIO::	readkey
0	0	0	0	0	FITSIO::	readpix
0	0	0	0	0	FITSIO::	readtblcol
0	0	0	0	0	FITSIO::	readtblcols
0	0	0	0	0	FITSIO::	reform_tbl
0	0	0	0	0	FITSIO::	remove_key
0	0	0	0	0	FITSIO::	resetseqio
0	0	0	0	0	FITSIO::	resize
0	0	0	0	0	FITSIO::	resize_img
0	0	0	0	0	FITSIO::	rmcols
0	0	0	0	0	FITSIO::	rmkey
0	0	0	0	0	FITSIO::	rmkeys
0	0	0	0	0	FITSIO::	rmode
0	0	0	0	0	FITSIO::	rmrows
0	0	0	0	0	FITSIO::	size
0	0	0	0	0	FITSIO::	statr
0	0	0	0	0	FITSIO::	status
0	0	0	0	0	FITSIO::	tblsize
0	0	0	0	0	FITSIO::	update_key
0	0	0	0	0	FITSIO::	val_to_type
0	0	0	0	0	FITSIO::	val_to_typecom
0	0	0	0	0	FITSIO::	wcs
0	0	0	0	0	FITSIO::	wcs_cel2pix
0	0	0	0	0	FITSIO::	wcs_get_im_keys
0	0	0	0	0	FITSIO::	wcs_pix2cel
0	0	0	0	0	FITSIO::	writeable
0	0	0	0	0	FITSIO::	writecol
0	0	0	0	0	FITSIO::	writecols
0	0	0	0	0	FITSIO::	writepix
0	0	0	0	0	FITSIO::	writetblcol
0	0	0	0	0	FITSIO::	writetblcols

Line	Stmts.	Exclusive Time	Avg.	Code
1				#! /usr/bin/env perl
2				#
3				# OO access to the cfitsio library, using the Astro:FITS::CFITSIO or
4				# the old CFITSIO module.
5				#
6
7				package FITSIO;
8
9	3	3.5e-5	1.2e-5	use strict; # spent 10µs making 1 call to strict::import
10	3	3.5e-5	1.2e-5	use warnings; # spent 24µs making 1 call to warnings::import
11
12	3	4.0e-5	1.3e-5	use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $AUTOLOAD $Banner); # spent 103µs making 1 call to vars::import
13	3	7.9e-5	2.6e-5	use Exporter; # spent 34µs making 1 call to Exporter::import
14	1	1.0e-6	1.0e-6	$VERSION = 0.90;
15	1	1.3e-5	1.3e-5	@ISA = qw(Exporter);
16
17	1	1.0e-6	1.0e-6	@EXPORT = qw();
18	1	3.0e-6	3.0e-6	@EXPORT_OK = qw(c_new c_split c_isit get_std_args check_sig
19				coltypename dcoltype coldispname);
20	1	6.0e-6	6.0e-6	%EXPORT_TAGS = (complex => [qw(c_new c_split c_isit)],
21				types => [qw(coltypename dcoltype coldispname)]);
22
23	3	0.00024	7.9e-5	use FileHandle; # spent 457µs making 1 call to FileHandle::import
24
25	3	2.7e-5	9.0e-6	use Carp qw(croak carp confess cluck); # spent 51µs making 1 call to Exporter::import
26	3	3.0e-5	1.0e-5	use File::Basename; # spent 53µs making 1 call to Exporter::import
27	3	2.7e-5	9.0e-6	use Cwd qw(chdir fastcwd); # spent 37µs making 1 call to Exporter::import
28
29	3	0.00086	0.00029	use Data::Dumper; # spent 69µs making 1 call to Exporter::import
30	3	0.00028	9.3e-5	use Math::Complex; # spent 263µs making 1 call to Exporter::import
31
32				#use lib qw(/wise/base/deliv/dev/lib/perl);
33
34				# Load Astro:FITS::CFITSIO if it's available, otherwise use the old CFITSIO
35				# module. In the former case we need to alias two routines not exported to
36				# their old CFITSIO i/o names for compatability.
37				BEGIN {
38	1	1.0e-6	1.0e-6	my @require_errs;
39				{ # Scope for 'no warnings' and local $SIG...
40				# This kluge is necessary because the 'die' in a failed 'require'
41				# does NOT interact as one expects with CGI::Carp::fatalsToBrowser.
42				# Thus we must not die but detect the load failure another way.
43	2	7.0e-6	3.5e-6	local $SIG{__DIE__} = sub { push @require_errs, @_; };
44	1	5.0e-6	5.0e-6	eval {
45	1	0.00177	0.00177	require Astro::FITS::CFITSIO;
46	1	1.4e-5	1.4e-5	Astro::FITS::CFITSIO->import(qw(:shortnames :constants)); # spent 7.84ms making 1 call to Exporter::import
47	3	8.4e-5	2.8e-5	no warnings; # spent 28µs making 1 call to warnings::unimport
48	1	4.0e-6	4.0e-6	CFITSIO::sizeof_datatype = Astro::FITS::CFITSIO::sizeof_datatype;
49	1	1.0e-6	1.0e-6	CFITSIO::PerlyUnpacking = Astro::FITS::CFITSIO::PerlyUnpacking;
50				};
51				}
52	1	1.0e-6	1.0e-6	if(@require_errs) {
53				# Old fashioned way for compatibility; load old CFITSIO module
54				eval {
55				require CFITSIO; CFITSIO->import(qw(:shortnames :constants));
56				};
57				}
58	1	1.0e-6	1.0e-6	die @require_errs,"\n",$@ if $@;
59	1	5.8e-5	5.8e-5	}
60
61				#
62				# Constants.
63				#
64
65				# (These aren't actually used right now)
66	3	5.1e-5	1.7e-5	use constant PI => atan2(1.0,1.0) * 4.0; # spent 63µs making 1 call to constant::import # spent 46µs making 1 call to Math::Complex::atan2
67	3	3.4e-5	1.1e-5	use constant R2D => 180.0 / PI; # spent 61µs making 1 call to constant::import
68	3	4.4e-5	1.5e-5	use constant S2 => sqrt(2.0); # spent 71µs making 1 call to constant::import # spent 13µs making 1 call to Math::Complex::sqrt
69				# This constant isn't defined in CFITSIO and I need it.
70	3	0.00017	5.6e-5	use constant NULL_UNDEFINED => 1234554321; # spent 49µs making 1 call to constant::import
71
72				# Return the RE to use to match to any legal C floating point number.
73				# This should be a fully embeddable pattern. The user must supply
74				# a boundary, e.g. /^$fpre$/.
75				# spent 107µs within FITSIO::fpre which was called 2 times, avg 54µs/call: # once (58µs+0) at line 94 # once (49µs+0) at line 95 sub fpre {
76	2	2.0e-6	1.0e-6	my $d = shift \|\| "";
77	2	0	0	$d = 'dD' if $d; # Is 'd' allowed instead of 'e' in the exponent?
78	2	4.0e-6	2.0e-6	my $re =
79				"(?:
80				[-+]? (?#_Optional_sign)
81				(?:
82				(?:(?:\\d*\\.?\\d+\|\\d+\\.)(?:[eE$d][-+]\\d+)?) \| (?#_Normal_number)
83				(?:nanq?\|inf(?:inity)) (?#_Special_values)
84				)
85				)
86				";
87	2	5.8e-5	2.9e-5	$re =~ s/[\s\n]//g; # Ensure readability without using (?x)
88	2	1.8e-5	9.0e-6	$re =~ s/nanq/[Nn][Aa][Nn][Qq]/; # Ensure case insenstivity w/o using (?i)
89	2	6.0e-6	3.0e-6	$re =~ s/inf/[Ii][Nn][Ff]/;
90	2	5.0e-6	2.5e-6	$re =~ s/inity/[Ii][Nn][Ii][Tt][Yy]/;
91	2	4.0e-6	2.0e-6	return $re;
92				}
93
94	3	4.1e-5	1.4e-5	use constant FPRE => fpre(); # spent 58µs making 1 call to FITSIO::fpre # spent 42µs making 1 call to constant::import
95	3	0.00979	0.00326	use constant FPRE_D => fpre(1); # spent 49µs making 1 call to FITSIO::fpre # spent 47µs making 1 call to constant::import
96
97				# Standard cfitsio banner; so we can skip it when we see it to avoid
98				# repeating it in newly created primary HDUs. See the end of create_hdus().
99	1	1.0e-6	1.0e-6	$Banner =
100				"(".
101				"FITS \$Flexible Image Transport System\$ format\|".
102				"volume 376, page 359; bibcode: 2001\|".
103				"Astrophysics Supplement Series\|".
104				"Contact the NASA Science Office\|".
105				"FITS Definition document".
106				")";
107
108				# CVS revision ID
109	1	1.0e-6	1.0e-6	my $version = '$Id: FITSIO.pm 7790 2010-04-13 22:53:48Z tim $ ';
110
111				# Error and warning prefixes.
112	1	0	0	my $err = "*** FITSIO";
113	1	1.0e-6	1.0e-6	my $warn = "=== FITSIO";
114
115				#
116				# Class data
117				#
118
119	1	0	0	$__Package__::Die_on_err = 0;
120
121				#
122				# OO methods
123				#
124
125				# Constructor method. Just a trivial front end for FITS_open.
126				sub new {
127				my $opts = ref($_[-1]) && ! is_fitsio($_[-1]) ? pop : {};
128				my $this = shift;
129				my $file = shift;
130				confess "$err: No input file specified" if ! defined $file && ! ref $this;
131				my $class = ref($this) \|\| $this;
132				$this = FITS_open(defined $file ? $file : $this, $opts) or return;
133
134				return bless $this,$class;
135				}
136
137				# Close file on destruction. We ignore errors since the state of the
138				# file and it's meta-data is unknown.
139				sub DESTROY {
140				my $this = shift;
141
142				#print "--- DESTROY: fileptr=".($this->{-fileptr}//"undef").
143				# " closed=".($this->{-closed}//"undef")."\n";
144
145				if($this && ! $this->{-closed}) {
146				end($this,{robust=>1});
147				}
148				}
149
150				sub end {
151				check_sig(';$',\@_) or confess; # '
152				my ($this,$opts,@args) = get_std_args(@_);
153				return &FITS_close($this,$opts);
154				}
155
156				sub status {
157				check_sig(';$',\@_) or confess; # '
158				my ($this,$opts,@args) = get_std_args(@_);
159				my $old = $this->{-status};
160				$this->{-status} = shift @args if @args;
161				return $old;
162				}
163				sub fp { check_sig(";",\@_) or confess; return (shift)->{-fileptr}; }
164				sub statr { check_sig(";",\@_) or confess; return \ (shift)->{-status}; }
165				sub mode { check_sig(";",\@_) or confess; return (shift)->{-mode}; }
166				sub rmode { check_sig(";",\@_) or confess; return (shift)->{-rmode}; }
167				sub file { check_sig(";",\@_) or confess; return (shift)->{-file}; }
168				sub writeable { check_sig(";",\@_) or confess; return (shift)->{-writeable}; }
169
170				sub size {
171				check_sig(';$$',\@_) or confess;
172				my ($this,$opts,@args) = get_std_args(@_);
173				my $hdunum = shift @args;
174				my ($type);
175
176				$hdunum = hdunum($this,$hdunum \|\| $opts->{hdunum}) or return;
177
178				$type = get_hdu_type(fp($this),statr($this));
179				handle_err($this,"$err/SIZE",$opts) or return;
180
181				if($type eq 'IMAGE') {
182				return imsize($this,$opts);
183				} else {
184				return tblsize($this,$opts);
185				}
186				}
187
188				sub nrows { return scalar &size; }
189
190				sub offsets {
191				check_sig(';$$',\@_) or confess;
192				my ($this,$opts,@args) = get_std_args(@_);
193				my $hdunum = shift @args;
194				$hdunum = hdunum($this,$hdunum \|\| $opts->{hdunum}) or return;
195
196				my @info = get_hdu_offsets(fp($this),statr($this));
197				handle_err($this,"$err/offsets: Attempt to get offset info failed",$opts)
198				or return;
199
200				return wantarray ? @info : $info[1];
201				}
202
203				sub numhdus {
204				check_sig(';$',\@_) or confess; # '
205				my ($this,$opts,@args) = get_std_args(@_);
206				my ($n,$hdunum);
207
208				$hdunum = hdunum($this,$hdunum \|\| $opts->{hdunum}) or return;
209
210				$n = get_num_hdus(fp($this),statr($this));
211				handle_err($this,"$err/NHDUS",$opts) or return;
212				return $n;
213				}
214
215				sub dumphdu {
216				check_sig(';$$',\@_) or confess;
217				my ($this,$opts,@args) = get_std_args(@_);
218				my $hdunum = shift @args;
219				return dump_hdu(fp($this),$hdunum,$opts,statr($this)) or return;
220				}
221				sub dumphdus { &dumphdu; }
222
223				sub hdutype {
224				check_sig(';$$',\@_) or confess;
225				my ($this,$opts,@args) = get_std_args(@_);
226				my $hdunum = shift @args;
227				my ($type);
228
229				$hdunum = hdunum($this,$hdunum \|\| $opts->{hdunum}) or return;
230
231				$type = get_hdu_type(fp($this),statr($this));
232				handle_err($this,"$err/HDUTYPE",$opts) or return;
233
234				return $type;
235				}
236
237				sub currhdu {
238				check_sig(';$',\@_) or confess; # '
239				my ($this,$opts,@args) = get_std_args(@_);
240				my ($hdunum);
241
242				$hdunum = get_curr_hdu(fp($this),statr($this));
243				handle_err($this,"$err/CURRHDU",$opts) or return;
244
245				return $hdunum;
246				}
247
248				sub hdunum {
249				# Used alot, so we'll skip signature checking for speed purposes
250				# check_sig(';$$',\@_) or confess;
251				my ($this,$opts,@args) = get_std_args(@_);
252				my $hdunum = shift @args \|\| $opts->{hdunum};
253				my ($type);
254
255				if($hdunum) {
256				$type = move_to_hdu(fp($this),$hdunum,statr($this));
257				} else {
258				$type = get_hdu_type(fp($this),statr($this));
259				$hdunum = get_curr_hdu(fp($this),statr($this));
260				}
261				handle_err($this,"$err/HDUNUM (hdunum=$hdunum)",$opts) or return;
262
263				return wantarray ? ($hdunum,$type) : $hdunum;
264				}
265				sub hdun { &hdunum; }
266
267				sub hdumeta {
268				check_sig(';$$',\@_) or confess;
269				my ($this,$opts,@args) = get_std_args(@_);
270				my $hdunum = shift @args;
271				my ($meta,%myopts);
272
273				$myopts{merge} = $opts->{merge};
274				$myopts{full} = ! $opts->{std};
275				$myopts{hdunum} = $hdunum \|\| $opts->{hdunum};
276
277				$meta = get_hdu_meta(fp($this),\%myopts,statr($this));
278				handle_err($this,"$err/HDUMETA: Error on current HDU",$opts) or return;
279
280				return $meta;
281				}
282
283				sub gethdu {
284				my $meta = &hdumeta;
285				return if ! $meta;
286				if(ref($meta) =~ /array/i) { return [ map { $_->{-hdu} } @$meta ]; }
287				else { return $meta->{-hdu}; }
288				}
289				sub gethdus { &gethdu; }
290
291				sub hdrstr {
292				check_sig(';$$',\@_) or confess;
293				my ($this,$opts,@args) = get_std_args(@_);
294				my $hdunum = shift @args;
295				$hdunum \|\|= $opts->{hdunum};
296				$hdunum = hdunum($this,$hdunum);
297				my %myopts = (%$opts);
298				my $hdrstr = get_hdr_str(fp($this),\%myopts,statr($this));
299				handle_err($this,"$err/HDRSTR: Error reading HDU $hdunum",$opts) or return;
300				return $hdrstr;
301				}
302
303				sub key {
304				check_sig(';$$',\@_) or confess;
305				my ($this,$opts,@args) = get_std_args(@_);
306				my $name = shift @args;
307				my ($num,$full,$kv,$ashash,$ordered);
308				my $not = $opts->{not};
309				$not = [$not] if $not && ! ref $not;
310				my %not = map { ($_ => 1) } @$not; # not used yet
311				local $_;
312
313				$name \|\|= $opts->{name} \|\| $opts->{key} \|\| $opts->{keyname} \|\|
314				$opts->{keyrec};
315				$kv = $opts->{kv}; # Return set of keys as a keyval hash
316				$ordered = $opts->{orderedkv}; # Return ordered keyval hash
317				$kv \|\|= $ordered;
318
319				my $hdunum = hdunum($this,$opts->{hdunum});
320
321				if(ref($name) && ref($name->[0])) { # Modify key or keys
322				my ($n,$defs);
323				if(! $this->writeable) {
324				status($this,10000);
325				handle_err($this,"$err/KEY: Attempt to update readonly file",
326				$opts);
327				return;
328				}
329				$defs = make_hdudef_std($name,$opts);
330				if(! $defs) {
331				status($this,10000);
332				handle_err($this,"$err/KEY: Couldn't standardize HDU def.",
333				$opts);
334				return;
335				}
336				for my $def (@$defs) {
337				update_key(fp($this),$def,statr($this));
338				handle_err($this,"$err/KEY: Attempt to update $def->{name} failed",
339				$opts) or return;
340				++$n;
341				}
342				return $n;
343
344				} elsif(ref($name)) { # Return a bunch of values
345
346				my @vals;
347
348				if(@$name == 1 && $name->[0] =~ /^[*%]$/) {
349				# Special case; return all header cards
350				my $hdu = gethdu($this,$hdunum);
351				$name = [ map { $_->{name} } @$hdu ];
352				}
353
354				for (@$name) {
355				next if ! defined $_ \|\| ! length $_;
356				my @cols;
357				if(/[#?*]/) {
358				# A FITSIO meta-character has been defined.
359				# Expand to all matching columns.
360				my ($newcols,$order) = get_col_num(fp($this),$_,statr($this));
361				#print "~~~~~~~ '$_' got back ".
362				# (join",",keys%$newcols)."=>".(join",",values%$newcols).
363				# " in order ".(join",",@$order);
364				next if ! $newcols \|\| ! keys %$newcols;
365				@cols = @{$newcols}{@$order};
366				#print "~~~~~~~ $_ matched columns @cols";
367				} else {
368				@cols = ($_);
369				}
370
371				for (@cols) {
372				my $val = readkey($this,$_,$opts);
373				push @vals, ($kv ? ($_=>$val) : ($val));
374				}
375				}
376				if(! $ordered \|\| wantarray) {
377				return wantarray ? @vals : ($kv ? {@vals} : \@vals);
378				} else {
379				eval "use Tie::IxHash; 1;" or die "$@";
380				tie(my %vals, 'Tie::IxHash', @vals);
381				return \%vals;
382				}
383				} else { # Simple, scalar key name or number; return one value
384				return readkey($this,$name,$opts);
385				}
386				}
387				sub hdukey { &key; }
388				sub hdukeys { &key; }
389
390				sub keyhash {
391				check_sig(';$',\@_) or confess;
392				my ($this,$opts,@args) = get_std_args(@_);
393				my $name \|\|= $opts->{name} \|\| $opts->{key} \|\| $opts->{keyname} \|\|
394				$opts->{keyrec};
395				$name \|\|= ['*'];
396				return key($this,$name,{kv=>1,%$opts});
397				}
398
399				sub rmkey {
400				check_sig(';$$',\@_) or confess;
401				my ($this,$opts,@args) = get_std_args(@_);
402				my $not = $opts->{keep} \|\| $opts->{not};
403				my $name = shift @args;
404				my $n = 0;
405				my @remove;
406
407				$name \|\|= $opts->{name} \|\| $opts->{key} \|\| $opts->{keyname} \|\|
408				$opts->{keyrec};
409
410				my $hdunum = hdunum($this,$opts->{hdunum});
411
412				if(! ref $name) { $name = [$name]; }
413
414				if($not) {
415				# Delete all but the given list.
416				my @all = map {$_->{name}} @{ $this->gethdu() };
417				my %keep;
418				@keep{@$name} = ();
419				@remove = grep ! exists $keep{$_}, @all;
420				#print "Remove: @remove\nAll: @all\n";
421				} else {
422				@remove = @$name;
423				}
424
425				for (@remove) {
426				remove_key(fp($this),$_,statr($this));
427				handle_err($this,"$err/RMKEY: Attempt to remove '$_' failed",$opts)
428				or return;
429				++$n;
430				}
431
432				return $n;
433				}
434				sub rmkeys { &rmkey; }
435
436
437				sub iostate {
438				check_sig(';$$',\@_) or confess;
439				my ($this,$opts,@args) = get_std_args(@_);
440				my $col = shift @args;
441				my ($hdunum,$clear,$new);
442
443				$hdunum = hdunum($this,$opts->{hdunum}) or return;
444				$col \|\|=$opts->{cols} \|\| $opts->{col} \|\| $opts->{column}\|\| $opts->{columns};
445				$clear = $opts->{clear};
446				$new = $opts->{new};
447
448				if($clear) {
449				my $old = $this->{-hdus}[$hdunum-1]{-iostate};
450				$this->{-hdus}[$hdunum-1]{-iostate} = undef;
451				return $old;
452				}
453
454				if($new) {
455				my $old = $this->{-hdus}[$hdunum-1]{-iostate};
456				$this->{-hdus}[$hdunum-1]{-iostate} = $new;
457				return $old;
458				}
459
460				my $iostate = $this->{-hdus}[$hdunum-1]{-iostate};
461				return if ! $iostate;
462
463				if(! $opts->{_ref}) {
464				# Make a copy to safely pass to the user. Internal calls use _ref=>1.
465				$iostate =
466				{%$iostate,
467				# Now copy deep data
468				cols =>
469				[ map { defined $_ ? {(%$_)} : undef } @{$iostate->{cols}} ]
470				};
471				}
472				return $iostate if ! defined $col;
473				if($col eq '-1') { # Return info for all accessed columns
474				return [ grep defined $_,@{$iostate->{cols}} ];
475				}
476				my $ix = $this->colix($col);
477				return if ! $ix;
478				return { $iostate->{cols}[$ix-1] };
479				}
480				sub ioinfo { &iostate; }
481
482				sub nread {
483				check_sig(';$$',\@_) or confess;
484				my ($this,$opts,@args) = get_std_args(@_);
485				my $hdunum = shift @args;
486				@{$opts->{qw(hdunum _ref)}} = ($hdunum\|\|$opts->{hdunum},1);
487				my $iostate = iostate($this,-1,$opts);
488				return if ! $iostate \|\| ! @$iostate;
489				return $iostate->[0]{nrows};
490				}
491				sub nwritten { &nread; }
492
493				sub resetseqio {
494				check_sig(';$$',\@_) or confess;
495				my ($this,$opts,@args) = get_std_args(@_);
496				my $hdunum = shift @args;
497				@{$opts}{qw(hdunum _ref)} = ($hdunum\|\|$opts->{hdunum},1);
498				my $iostate = iostate($this,-1,$opts);
499				return if ! $iostate;
500				for (@{$iostate}) {
501				$_->{row}=0; $_->{seq}=0; $_->{EOF}=0;
502				}
503				return 1;
504				}
505
506				sub cleario {
507				check_sig(';$$',\@_) or confess;
508				my ($this,$opts,@args) = get_std_args(@_);
509				my $hdunum = shift @args;
510				$opts->{hdunum} = $hdunum \|\| $opts->{hdunum};
511				$opts->{clear} = 1;
512				iostate($this,$opts);
513				return 1;
514				}
515
516
517				# Read/write multiple rows of multiple cols.
518				# This routine is bimorphic; if the 'outdata' option is specified, data
519				# is written rather than read.
520				sub readtblcol {
521				check_sig(';$$',\@_) or confess;
522				my ($this,$opts,@args) = get_std_args(@_);
523				my $col = shift @args;
524				my (%cols,$cols,$order,@order,$fp,$name,$hdunum,$onecol,$data);
525				my ($writing,$use,$outdata,$myoutdata,$i,$ref,$read,$reading,
526				$stack,$append,$orderasgiven,$lc);
527
528				$hdunum = hdunum($this,$opts->{hdunum}) or return;
529
530				# Find the column(s) desired
531				$col \|\|= $opts->{'col'} \|\| $opts->{'column'} \|\|
532				$opts->{'cols'} \|\| $opts->{'columns'};
533
534				$fp = fp($this);
535
536				$outdata = $opts->{outdata};
537				#print Dumper $outdata;
538				$writing = defined $outdata;
539				$reading = ! $writing;
540				$use = $writing ? "WRTBLCOL" : "RDTBLCOL";
541
542				$stack = $opts->{stack} && $opts->{packed};
543				$append = $opts->{append} && $opts->{packed};
544
545				$lc = $opts->{lc};
546
547				$orderasgiven = $reading && ref($col) =~ /array/i;
548
549				if(! defined $col && $writing) {
550				# (The \ {col1,col2,...} for is so the user can distinguish
551				# between an outdata specification hash and an options hash.)
552				$col = ref($outdata) =~ /scalar/i ? [keys %$$outdata] :
553				ref($outdata) =~ /hash/i ? [keys %$outdata] :
554				ref($outdata) =~ /array/i ? [1..@$outdata] :
555				undef;
556				}
557
558				#print "COL=$col, outdata=$outdata, writing=$writing\n";
559
560				($cols,$order) = normalize_cols($fp,$col,statr($this)) or return;
561
562				if(! $orderasgiven) {
563				$order = [sort {$a<=>$b} @$order];
564				}
565
566				#print "@$col // @$order\n" if $writing; # XXXXXX
567				#while(my($k,$v)=each%$cols) { print "\t$k => $v\n"; } # XXXXXX
568
569				if(! %$cols) {
570				# No columns found.
571				status($this,10000);
572				handle_err($this,"$err/$use: Requested columns not in table",$opts);
573				return;
574				}
575
576				if($reading) {
577				$data = $opts->{array} ? [] :
578				$stack ? \ my $tmp
579				: {};
580				}
581
582				# Get/put data one column at a time, in user specified order if requested,
583				# otherwise in table column order.
584				my @outcols;
585				for my $ix (0..$#{$order}) {
586				my $col = $order->[$ix];
587				my $name = $lc ? lc $cols->{$col} : $cols->{$col};
588
589				if($writing) {
590				# (The \ {col1,col2,...} for is so the user can distinguish
591				# between an outdata specification hash and an options hash.)
592				$myoutdata = ref($outdata)=~/scalar/i ? {$$outdata}->{$name} :
593				ref($outdata)=~/hash/i ? $outdata->{$name} :
594				ref($outdata)=~/array/i ? $outdata->[$ix] :
595				$outdata;
596				#print "Writing column $ix/$name/$col = /$outdata/$myoutdata/ ....\n";
597				push @outcols, $name;
598				next if ! defined $myoutdata;
599				}
600
601				# print " Getting column $name=>$col $ref/$data->{$name} ...\n"; #####
602				# $onecol is unpacked data (unless 'packed' is specified) for one column
603				$onecol = read1tblcolbynum($this,{%$opts, # Inherit opts
604				# But add/override these
605				colnum =>$col,
606				hdunum =>$hdunum,
607				outdata=>$myoutdata
608				});
609				# print " Returning data is in $onecol/$data->{$name}.\n"; #####
610				return if ! defined $onecol; # Error
611				return 0 if ! $onecol; # EOF (won't happen if writing)
612
613				if($reading) {
614				if($opts->{array}) {
615				$data->[$ix] = $onecol;
616				${$opts->{append}[$ix]} .= $$onecol if $append;
617				} elsif($stack) { # Stack the columns in a single buffer
618				$$data .= $onecol;
619				${$opts->{append}} .= $$onecol if $append;
620				} else {
621				if(! $lc) {
622				$data->{$name} = $onecol;
623				${$opts->{append}{$name}} .= $$onecol if $append;
624				} else {
625				$data->{lc $name} = $onecol;
626				${$opts->{append}{lc $name}} .= $$onecol if $append;
627				}
628				}
629				} else {
630				++$data;
631				}
632				}
633
634				# print "Returning data at $data .\n"; #####
635				if($writing && ! $data) {
636				status($this,10000);
637				handle_err($this,"$err/$use: Found no data in output structure ".
638				"for columns @outcols".
639				(ref($outdata)=~/hash/i
640				? "; data cols = ".join(" ",sort keys %$outdata) : ""),
641				$opts)
642				or return;
643				}
644
645				return $data;
646				}
647				sub readtblcols { &readtblcol; }
648				sub readcol { &readtblcol; }
649				sub readcols { &readtblcol; }
650
651
652				sub writetblcol {
653				check_sig(';$$',\@_) or confess;
654				#print "@_\n";
655				my ($this,$opts,@args) = get_std_args(@_);
656				my $outdata = shift @args;
657
658				$outdata \|\|= $opts->{outdata};
659				if(! $outdata) {
660				status($this,10000);
661				handle_err($this,"$err/wrtblcol: No output data specified",$opts);
662				return;
663				}
664
665				return readtblcol($this,undef,{%$opts, outdata=>$outdata});
666				}
667				sub writetblcols { &writetblcol; }
668				sub writecol { &writetblcol; }
669				sub writecols { &writetblcol; }
670
671				sub rmrows {
672				check_sig(';$$',\@_) or confess;
673				my ($this,$opts,@args) = get_std_args(@_);
674				my $rows = shift @args;
675				my ($hdunum);
676
677				$hdunum = hdunum($this,$opts->{hdunum}) or return;
678				$rows \|\|= $opts->{rows} \|\| $opts->{rows};
679
680				delete_tbl_rows(fp($this),$rows,statr($this));
681				handle_err($this,"$err/RMROWS: Attempt to remove rows failed",$opts)
682				or return;
683				my $meta = hdumeta($this);
684				handle_err($this,"$err/RMROWS: Attempt to resync HDU failed", $opts)
685				or return;
686				$this->{-hdus}[$hdunum-1] = $meta;
687
688				return 1;
689				}
690				sub delrows { &rmrows; }
691
692				sub rmcols {
693				check_sig(';$$',\@_) or confess;
694				my ($this,$opts,@args) = get_std_args(@_);
695				my $cols = shift @args;
696				my ($hdunum);
697				$hdunum = hdunum($this,$opts->{hdunum}) or return;
698				$cols \|\|= $opts->{cols} \|\| $opts->{cols};
699				#print "--- @$cols\n";
700				delete_tbl_cols(fp($this),$cols,statr($this));
701				handle_err($this,"$err/RMCOLS: Attempt to remove cols failed",$opts)
702				or return;
703				my $meta = hdumeta($this);
704				handle_err($this,"$err/RMCOLS: Attempt to resync HDU failed", $opts)
705				or return;
706				$this->{-hdus}[$hdunum-1] = $meta;
707
708				return 1;
709				}
710				sub delcols { &rmcols; }
711
712				sub colinfo {
713				check_sig(';$$',\@_) or confess;
714				my ($this,$opts,@args) = get_std_args(@_);
715				my $col = shift @args;
716				my ($hdunum,$info);
717
718				$hdunum = hdunum($this,$opts->{hdunum}) or return;
719				$col \|\|= $opts->{col} \|\| $opts->{column};
720
721
722				if(defined $col && ! ref $col && $col !~ /[*#?]/) {
723				# Single, unqiue column
724				#print "Looking for column $col ... ";
725				$col = colnum($this,$col);
726				#print "got number $col\n";\
727				# Make a shallow copy
728				$info = { %{ get_col_info(fp($this),$col,statr($this)) \|\| {} } };
729				} else {
730				# Possibly multiple columns
731				if(! $col) {
732				# All columns
733				$info = get_all_col_info(fp($this),statr($this));
734				} else {
735				# Some columns (or maybe all)
736				my %cols = map { colnums($this,$col) } (ref $col ? @$col : $col);
737				#print "/$col/ = ",Dumper(\%cols);
738				$info = [];
739				for (keys %cols) {
740				my $info1 = get_col_info(fp($this),$cols{$_},statr($this));
741				last if status($this) > 0;
742				push @$info, $info1;
743				}
744				}
745				#print Dumper $info;
746				# Recast as hash
747				my %info;
748				# Make a shallow copy
749				for (@$info) { $info{$_->{name}} = { %{ $_ \|\| {} } }; }
750				$info = \%info;
751				}
752				handle_err($this,"$err/COLINFO: Attempt to get col info failed",$opts)
753				or return;
754
755				return $info;
756				}
757
758				sub colnum {
759				check_sig(';$$',\@_) or confess;
760				my ($this,$opts,@args) = get_std_args(@_);
761				my $colname = shift @args;
762				my ($hdunum,$col,%info);
763
764				$hdunum = hdunum($this,$opts->{hdunum}) or return;
765
766				$colname \|\|= $opts->{col} \|\| $opts->{column};
767				my $colnum \|\|= $opts->{colnum};
768				$col = $colnum \|\| $colname \|\| "*";
769
770				%info = %{ (normalize_cols(fp($this),$col,statr($this)))[0] \|\| {} };
771				handle_err($this,"$err/COLNUM: Attempt to get col '$col' failed",$opts)
772				or return;
773				return wantarray ? reverse %info # All names as name=>number pairs
774				: scalar(keys %info); # No. of cols
775				}
776				sub colix { &colnum; }
777				sub colnums { &colnum; }
778
779				sub colname {
780				check_sig(';$$',\@_) or confess;
781				my ($this,$opts,@args) = get_std_args(@_);
782				my $column = shift @args;
783
784				my $colnum = $opts->{colnum};
785
786				my %names;
787
788				%names = colnum($this,{%$opts,column=>$column,colnum=>$colnum});
789
790				if($colnum) {
791				# One column number
792				return $names{$colnum+0};
793				} else {
794				# Many column names, in order.
795				my @names = sort { $names{$a} <=> $names{$b} } keys %names;
796				return wantarray ? @names : \@names;
797				}
798
799				}
800				sub colnames { &colname; }
801
802				sub optrows {
803				check_sig(';$$',\@_) or confess;
804				my ($this,$opts,@args) = get_std_args(@_);
805				my $hdunum = shift @args;
806
807				$hdunum = hdunum($this,$hdunum \|\| $opts->{hdunum}) or return;
808				my $rows = getoptrows(fp($this),statr($this));
809				handle_err($this,"$err/OPTROWS: Attempt to get optimal rows",$opts)
810				or return;
811
812				return $rows;
813				}
814
815				sub dumpcols {
816				check_sig(';$$',\@_) or confess;
817				my ($this,$opts,@args) = get_std_args(@_);
818				my $data = shift @args;
819
820				$data \|\|= $opts->{data};
821
822				if(! $data) {
823				$data = readcol($this,$opts);
824				return if ! defined $data; # ERROR
825				}
826				return 0 if ! $data; # EOF
827				my $myopts = { %$opts };
828				$myopts->{cols} = $myopts->{col} = $myopts->{columns} = $myopts->{column}
829				= undef;
830				my $iostate = iostate($this,{%$myopts,_ref=>1});
831				dump_cols($data,$iostate,{$this->colix($opts)},$myopts);
832
833				return 1;
834				}
835
836				sub resize {
837				check_sig(';$$',\@_) or confess;
838				my ($this,$opts,@args) = get_std_args(@_);
839				my $axes = shift @args;
840				my $hdunum;
841
842				$hdunum = hdunum($this,$opts->{hdunum}) or return;
843
844				resize_img(fp($this),$axes,0,statr($this));
845				handle_err($this,"$err/RESIZE: Attempt to resize image failed", $opts)
846				or return;
847				my $meta = hdumeta($this);
848				handle_err($this,"$err/RESIZE: Attempt to resync HDU failed", $opts)
849				or return;
850				$this->{-hdus}[$hdunum-1] = $meta;
851
852				return 1;
853				}
854
855				sub imtype {
856				check_sig(';$$',\@_) or confess;
857				my ($this,$opts,@args) = get_std_args(@_);
858				my $hdunum = shift @args;
859
860				$hdunum = hdunum($this,$hdunum \|\| $opts->{hdunum}) or return;
861
862				my $type = bpix2type(getbpix(fp($this),statr($this)));
863				handle_err($this,"$err/IMTYPE: Attempt get im type failed", $opts)
864				or return;
865
866				return $type;
867				}
868
869				sub writepix {
870				check_sig(';$$',\@_) or confess;
871				my ($this,$opts,@args) = get_std_args(@_);
872				my $pix = shift @args;
873				my ($buf,$type,$hdunum,$ref,$noscale);
874
875				$pix = defined $pix ? $pix : $opts->{pix};
876
877				if(ref($pix) =~ /^pdl(::\|$)/i) {
878				require PDL::Lite;
879				$type = {PDL_F=>'E', PDL_D=>'D', PDL_S=>'I', PDL_US=>'I',
880				PDL_L=>'J', PDL_LL=>'K', PDL_B=>'B'}
881				->{$pix->type->symbol};
882				#print "--- ",$pix->type->symbol,", $type\n";
883				$pix = $pix->get_dataref();
884				}
885
886				$hdunum = hdunum($this,$opts->{hdunum}) or return;
887
888				$type = $opts->{type} \|\|
889				bpix2type(getbpix(fp($this),statr($this)));
890				$noscale = $opts->{noscale};
891
892				if(! $type) {
893				status($this,10000);
894				handle_err($this,"$err/WRITEPIX: No type for pixels", $opts)
895				or return;
896				}
897				if(ref($pix) =~ /array/i) {
898				my $ptype = pcoltype($type,0);
899				print "Packing ".@$pix." elements of type $type ($ptype).\n"
900				if $opts->{verbose};
901				$pix = pack("${ptype}*",@$pix);
902				$ref = \$pix;
903				} elsif (ref($pix) =~ /scalar/i) {
904				$ref = $pix;
905				} elsif (ref($pix)) {
906				confess "$err/WRITEPIX: Pixels are a $pix; don't know what to do.\n";
907				} else {
908				$ref = \ $pix;
909				}
910				put_impix(fp($this),$ref,$type,$noscale,statr($this));
911				handle_err($this,"$err/WRITEPIX: Attempt to write pixels failed", $opts)
912				or return;
913
914				return 1;
915				}
916
917				sub readpix {
918				check_sig(';$$',\@_) or confess;
919				my ($this,$opts,@args) = get_std_args(@_);
920				my $pix = shift @args;
921				my ($buf,$type,$hdunum,$ref,$noscale);
922
923				$hdunum = hdunum($this,$opts->{'hdunum'}) or return;
924				$type = $opts->{type};
925				$noscale = $opts->{noscale};
926
927				if(ref($pix) =~ /scalar/i) {
928				$ref = $pix;
929				} elsif (ref($pix)) {
930				confess "$err/WRITEPIX: Pixel ref is a $pix; don't know what to do.\n";
931				} else {
932				my ($npix,$pixsz);
933				($npix,$pixsz) = imsize($this) or return;
934				$pix= " " x ($npix*$pixsz);
935				$ref = \ $pix;
936				}
937				get_impix(fp($this),$ref,$type,$noscale,statr($this));
938				handle_err($this,"$err/READPIX: Attempt to read pixels failed", $opts)
939				or return;
940
941				return $ref;
942				}
943
944				sub axes {
945				check_sig(';$$',\@_) or confess;
946				my ($this,$opts,@args) = get_std_args(@_);
947				my $hdunum = shift @args;
948				my $nelems = 0;
949				my $nbytes = 0;
950				my ($tp,$naxis,$naxes);
951
952				$hdunum = hdunum($this,$hdunum \|\| $opts->{'hdunum'}) or return;
953
954				($nelems,$nbytes,$naxis,$naxes) =
955				get_im_size(fp($this),statr($this));
956				handle_err($this,"$err/AXES",$opts) or return;
957
958				#print "@$naxes\n";
959
960				return @$naxes;
961				}
962
963				sub newhdu {
964				check_sig(';$$',\@_) or confess;
965				my ($this,$opts,@args) = get_std_args(@_);
966				my $hdudefs = shift @args;
967				my $hdunum;
968
969				$hdunum = hdunum($this,$opts->{hdunum}) or return;
970
971				$hdudefs \|\|= $opts->{hdudefs} \|\| $opts->{hdudef};
972
973				create_hdus(fp($this),$hdudefs,$opts,statr($this));
974				handle_err($this,"$err/NEWHDU: Adding/updating of header(s) failed",$opts)
975				or return;
976
977				return 1;
978				}
979
980				sub getwcs {
981				check_sig(';$$',\@_) or confess;
982				my ($this,$opts,@args) = get_std_args(@_);
983				my $hdunum = shift @args;
984				my (@wcs,$newwcs);
985				if(ref $hdunum) { $newwcs=$hdunum; $hdunum=undef; }
986				elsif(ref $this) { $hdunum = hdunum($this,$hdunum \|\| $opts->{hdunum})
987				or return; }
988				if(! $newwcs && ref $this) {
989				my $statr = $this->statr();
990				eval "use Astro::WCS::LibWCS;";
991				if($@) {
992				handle_err($$statr=10000,
993				"$err/GETWCS: Can't load wcslib; $@");
994				return;
995				}
996				my $hdr = $this->hdrstr();
997				handle_err($this,"$err/NEWHDU: getting header info failed",$opts)
998				or return;
999				my $wcs = Astro::WCS::LibWCS::wcsinit($hdr);
1000				if(! $wcs) {
1001				handle_err($$statr=10000,"$err/GETWCS: Getting WCS object failed");
1002				return;
1003				}
1004				$this->{-hdus}[$hdunum-1]{-wcs} = $wcs;
1005				return $wcs;
1006				} else {
1007				$newwcs \|\|= $opts->{wcs};
1008				@wcs = @$newwcs if ref($newwcs) =~ /array/i;
1009				@wcs = @{$newwcs}{qw/lon0 lat0 x0 y0 dx dy twist proj/}
1010				if ref($newwcs) =~ /hash/i;
1011				$wcs[2] \|\|= 0;
1012				$wcs[3] \|\|= $wcs[2];
1013				$wcs[4] \|\|= -1/3600;
1014				$wcs[5] \|\|= abs($wcs[4]);
1015				$wcs[6] \|\|= 0;
1016				$wcs[7] \|\|= '-TAN';
1017				return \@wcs;
1018				}
1019
1020				}
1021				sub wcs { &getwcs; }
1022
1023				# Next two written to be callable as functions, class methods
1024				# (if the 'wcs' option is supplied) or instance methods.
1025				sub cel2pix {
1026				my ($this,$opts,@args,$ra,$dec);
1027				my $fpre = FPRE;
1028				if(ref($_[0]) =~ /fitsio/i) { # Called as instance method
1029				check_sig('$$;$',\@_) or confess; # '
1030				($this,$opts,@args) = get_std_args(@_);
1031				($ra,$dec) = (shift(@args),shift(@args));
1032				} else { # Called as a function or class method
1033				unshift @_,'' if ref($_[0]) \|\| $_[0] =~ /^$fpre$/;
1034				($this,$ra,$dec,$opts) = @_;
1035				}
1036				my ($x,$y);
1037				my ($hdunum,$statr);
1038				my $wcs = $opts->{wcs}; # ($xref,$yref,$xpix,$ypix,$xdel,$ydel,$rot,$proj);
1039				if(! $wcs) {
1040				$hdunum= hdunum($this,$opts->{hdunum}) or return;
1041				$this->getwcs($opts) if ! $this->{-hdus}[$hdunum-1]{-wcs};
1042				$wcs = $this->{-hdus}[$hdunum-1]{-wcs};
1043				$statr = statr($this);
1044				} else {
1045				my $status = 0;
1046				$statr = \ $status;
1047				$wcs = $this->getwcs({wcs=>$wcs});
1048				}
1049				if(ref($wcs) =~ /array/i) {
1050				# Using CFITSIO internal WCS routines
1051				if(ref $ra) {
1052				for (0..$#{$ra}) {
1053				($x->[$_],$y->[$_])= wcs_cel2pix($ra->[$_],$dec->[$_],
1054				$wcs,$statr);
1055				}
1056				} else {
1057				($x,$y)= wcs_cel2pix($ra,$dec,$wcs,$statr);
1058				}
1059				} else {
1060				# Using WCSlib routines
1061				my $off=0;
1062				if(ref $ra) {
1063				for (0..$#{$ra}) {
1064				$wcs->wcs2pix($ra->[$_],$dec->[$_],$x->[$_],$y->[$_],$off);
1065				}
1066				} else {
1067				$wcs->wcs2pix($ra,$dec,$x,$y,$off);
1068				}
1069				}
1070				handle_err($$statr,"$err/CEL2PIX: Error performing conversion",$opts)
1071				or return;
1072				return ($x,$y);
1073				}
1074
1075				sub pix2cel {
1076				my ($this,$opts,@args,$x,$y);
1077				my $fpre = FPRE;
1078				if(ref($_[0]) =~ /fitsio/i) { # Called as object method
1079				check_sig('$$;$',\@_) or confess; # '
1080				($this,$opts,@args) = get_std_args(@_);
1081				($x,$y) = (shift(@args),shift(@args));
1082				} else { # Called as class method
1083				unshift @_,'' if ref($_[0]) \|\| $_[0] =~ /^$fpre$/;
1084				($this,$x,$y,$opts) = @_;
1085				}
1086				my ($ra,$dec);
1087				my ($hdunum,$statr);
1088				my $wcs = $opts->{wcs}; # ($xref,$yref,$xpix,$ypix,$xdel,$ydel,$rot,$proj);
1089				if(! $wcs) {
1090				$hdunum= hdunum($this,$opts->{hdunum}) or return;
1091				$this->getwcs($opts) if ! $this->{-hdus}[$hdunum-1]{-wcs};
1092				$wcs = $this->{-hdus}[$hdunum-1]{-wcs};
1093				$statr = statr($this);
1094				} else {
1095				my $status = 0;
1096				$statr = \ $status;
1097				$wcs = $this->getwcs({wcs=>$wcs});
1098				}
1099				if(ref($wcs) =~ /array/i) {
1100				if(ref $x) {
1101				for (0..$#{$x}) {
1102				($ra->[$_],$dec->[$_])= wcs_pix2cel($x->[$_],$y->[$_],
1103				$wcs,$statr);
1104				}
1105				} else {
1106				($ra,$dec)= wcs_pix2cel($x,$y,$wcs,$statr);
1107				}
1108				} else {
1109				if(ref $x) {
1110				for (0..$#{$x}) {
1111				$wcs->pix2wcs($x->[$_],$y->[$_], $ra->[$_],$dec->[$_]);
1112				}
1113				} else {
1114				$wcs->pix2wcs($x,$y, $ra,$dec);
1115				}
1116				}
1117				handle_err($$statr,"$err/PIX2CEL: Error performing conversion",$opts)
1118				or return;
1119				return ($ra,$dec);
1120				}
1121
1122				#
1123				# vvvvvvvvvvvvvvvv Internal access only vvvvvvvvvvvvvvvv
1124				# Do NOT attempt to call these subs directly externally.
1125				#
1126
1127				# The first set are highish level, meaning they take an object
1128				# instance and do error handling. After that are lower level routines
1129				# that usually expect a file pointer and status reference, plus other args.
1130
1131				# Open a FITS file to read, write or update. HDUs may be read. Image data may
1132				# be read. HDUs may be created from explicit definitions or from a model
1133				# FITS file already opened.
1134				# An object instance is returned upon success, undef on failure.
1135				sub FITS_open {
1136				my $opts = ref($_[-1]) && ! is_fitsio($_[-1]) ? pop : {};
1137				my $file = shift;
1138				# Mode translations
1139				my ($ro,$rw) = (READONLY,READWRITE);
1140				my %modes = (
1141				r=>$ro, ro=>$ro, read=>$ro, readonly=>$ro,
1142				input=>$ro, in=>$ro,
1143
1144				'r+'=>$rw, rw=>$rw, update=>$rw, modify=>$rw, mod=>$rw,
1145				readwrite=>$rw, alter=>$rw,
1146
1147				c=>'create', create=>'create', new=>'create',
1148				write=>'create', w=>'create', out=>'create'
1149				);
1150				my $this; # The object instance to-be
1151				# Other work var.s
1152				my ($fp); # fitsfile pointer
1153				my $stat; # Status return value
1154				my ($rmode); # Regularized mode
1155				my %info; # Info about the file and all HDUs
1156				my $hdu; # Full HDU data ref. for each HDU
1157				my %prime; # Prime array mandatory header contents
1158				my $nhdus = 0; # No. of HDUs
1159				my ($nelems,$size); # No. elements and size an elem. of an HDUs image
1160				my $ref; # Scalar reference to hold image data
1161				my $nnul; # Var(s) to hold various returned data
1162				my ($mode,$overwrite,$verbose,$data,$silentfail); # Some options
1163				# Random temporary local var.s
1164				my ($tp,$nm,$v,$std,$writeable,$nrows,$ncols,$old,$hdunum,
1165				$colinfo,$info,$colix,$colname,$naxis,$naxes,$bpix,$silent,
1166				$dieonerr);
1167				local $_;
1168
1169				# Resolve file name
1170				$file = defined $file ? $file : $opts->{file};
1171
1172				# Get options
1173				$mode = $opts->{mode};
1174				$verbose = $opts->{verbose} \|\| 0;
1175				$stat = $opts->{status} \|\| 0;
1176				$silent = $opts->{silent} \|\| 0;
1177				$hdunum = $opts->{hdunum} \|\| 1;
1178				$dieonerr = $opts->{dieonerr} \|\| $__Package__::Die_on_err;
1179
1180				if(is_fitsio($file)) {
1181				# We're re-opening
1182				$file = $this->file();
1183				$mode \|\|= 'readonly';
1184				$overwrite = 0;
1185				$old = $this; # Save old object for later use
1186				} elsif(ref $file) {
1187				confess "$err: Attempt to re-open on non-object";
1188				}
1189
1190				# Regularize I/O mode
1191				if(! defined $mode) {
1192				$mode = 'read' if $file =~ s/^<//;
1193				$mode = 'update' if $file =~ s/^(\+[<>]\|[<>]\+)//;
1194				$mode = 'write' if $file =~ s/^>\!//;
1195				$mode = 'new' if $file =~ s/^>//;
1196				}
1197				$mode \|\|= "readonly";
1198				$rmode = $modes{lc $mode}; # Canonical mode representation
1199
1200				if(! defined $rmode) {
1201				confess "$err: Mode '$mode' not understood.\n";
1202				}
1203				# Overwriting?
1204				$overwrite = $file =~ s/^\!// \|\| $rmode=~ m/create/ \|\| 0;
1205
1206				# Compressed and reading?
1207				$file .= ".gz" if ($rmode eq READWRITE \|\| $rmode eq READONLY) &&
1208				$file !~ /\.gz$/ && ! -e $file && -e "$file.gz";
1209
1210				my ($origfile,$tmpfile);
1211
1212				$origfile = $file;
1213
1214				if($rmode eq READWRITE && $file =~ /\.gz$/) {
1215				# Updating a compressed file.
1216				# CFITSIO does not provide this ability natively, so we
1217				# need to decompress to a temporary file, then recompress
1218				# when done in the DESTROY step.
1219				require File::Temp;
1220				require Compress::Zlib;
1221				require File::Slurp;
1222				(my $base = File::Basename::basename($file)) =~ s\|\..*\|\|;
1223				my $tmpfh;
1224				($tmpfh, $tmpfile) =
1225				File::Temp::tempfile("cfitsio-$base-XXXX",
1226				SUFFIX=>".fits",DIR=>"/tmp")
1227				or confess "$err: Unable to create temp. file; $!.\n";
1228				my $lines_ref = File::Slurp::read_file($file, scalar_ref=>1)
1229				or confess "$err: Unable to read file '$file' ".
1230				"for decompression; $!.\n";
1231				#print "--- Read ".length($$lines_ref)." bytes.\n";
1232				my $contents = Compress::Zlib::memGunzip($lines_ref)
1233				or confess "$err: Unable to gunzip file '$file'.\n";
1234				File::Slurp::write_file($tmpfh, \$contents)
1235				or confess "$err: Unable to write temp file '$tmpfile'; $!.\n";
1236				$file = $tmpfile;
1237				print "(Decompressed '$origfile' to '$tmpfile'.)\n"
1238				if $verbose;
1239				}
1240
1241				# Open the file
1242				$fp = open_file($file,$rmode,$overwrite,\$stat);
1243
1244				if($silent && $stat > 0) { return; } # Silent failure
1245
1246				handle_err($stat,
1247				"$err/open: Open with mode '$mode' ($rmode) failed",
1248				{%$opts,file=>$file})
1249				or return; # Will only fail/return if $stat > 0
1250
1251				$writeable = 1 if $rmode eq $rw \|\| $rmode eq 'create';
1252
1253				print +($opts->{dumphdus}?"\n":"").
1254				"File $file, mode=$mode, overwrite=$overwrite\n".
1255				($opts->{dumphdus}?("=" x 79):"").
1256				"\n"
1257				if $verbose;
1258
1259				if($writeable && ($opts->{hdudefs} \|\| $opts->{hdudef} \|\|
1260				$opts->{like} \|\| $opts->{with} )) {
1261				my $rc;
1262				# Add HDU(s) to the file
1263				print "\nCreating HDU's.\n" if $verbose;
1264				$rc = create_hdus($fp,$opts->{hdudefs}\|\|$opts->{hdudef},
1265				{like=>$opts->{like}\|\|$opts->{with},
1266				verbose=>$verbose},
1267				\$stat);
1268				handle_err($stat,"$err: Creation of header failed",$opts)
1269				or return; # Will only fail/return if $stat > 0
1270				ffrdef($fp,\$stat);
1271				handle_err($stat,"$err: Rescanning of new HDU failed",
1272				$opts) or return;
1273				}
1274
1275				# Get/print data about all the HDUs in the file
1276				$nhdus = get_num_hdus($fp,\$stat);
1277				handle_err($stat,
1278				"$err: Failed to get NHDUs",
1279				$opts)
1280				or return; # Will only fail/return if $stat > 0
1281				$info{-nhdus} = $nhdus;
1282				$info{-hdus} = [];
1283				#print "--- NHDUs = $nhdus\n";
1284				# Get and (optionally) print up to 10 hdus
1285				for(my $i=1; $i<=$nhdus; ++$i) {
1286				# warn("$warn: Truncated HDU pre-read.\n"),
1287				last if $i>10;
1288				move_to_hdu($fp,$i,\$stat);
1289				my $info = get_hdu_meta($fp,{},\$stat) or return;
1290				print +($opts->{dumphdus}?"\n":"").
1291				"HDU #$i; type=$info->{-hdutype}, ".
1292				"name='$info->{-hduname}', ".
1293				"version='$info->{-hduver}', nkeys=$info->{-nkeys}\n".
1294				($opts->{dumphdus}?("-" x 79):"")."\n"
1295				if $verbose \|\| $opts->{dumphdus};
1296				if($opts->{dumphdus}) {
1297				if(! $verbose) {
1298				for my $k (sort keys %{$info->{-std}}) {
1299				my $v = $info->{-std}{$k};
1300				print "\t$k\t=\t".(ref($v) ? join(",",@$v) : $v)."\n";
1301				}
1302				} else {
1303				print "\n";
1304				dump_hdu($fp,$i,{nohdr=>1,merge=>1},\$stat);
1305				print "\n";
1306				}
1307				}
1308				push @{$info{-hdus}},$info;
1309
1310				# Return to primary array or requested hdunum
1311				move_to_hdu($fp,$hdunum,\$stat);
1312				handle_err($stat,
1313				"$err: Failed to move to hdunum $hdunum",
1314				$opts)
1315				or return; # Will only fail/return if $stat > 0
1316				}
1317
1318				# Set up meta-data (instance data)
1319				$this = {
1320				-fileptr=>$fp, -file=>$file, -mode=>$mode,
1321				-cwd=>fastcwd(), -status=>$stat, -writeable=>$writeable,
1322				-mode=>$mode, -rmode=>$rmode, -overwrite=>$overwrite,
1323				-uptodate=>1, -dieonerr=>$dieonerr,
1324				-verbose=>$verbose,
1325				-tmpfile=>$tmpfile, -origfile=>$origfile,
1326				%info,
1327				};
1328
1329				# Close the file, if requested
1330				if($opts->{close}) {
1331				print "\nClosing file $file.\n" if $verbose;
1332				FITS_close($this,$opts) or return;
1333				}
1334
1335				# Successful return
1336				return $this;
1337				}
1338
1339				sub FITS_close {
1340				my ($this,$opts,@args) = get_std_args(@_);
1341				my ($warnem,$stat,$robust,$verbose);
1342
1343				$verbose= $opts->{verbose} \|\| $this->{-verbose};
1344				$warnem = $opts->{warn};
1345				$robust = $opts->{robust};
1346
1347				$stat = 0;
1348				close_file(fp($this),\$stat);
1349				status($this,$stat) if $stat != 0;
1350
1351				if($this->{-tmpfile} && ! $stat) {
1352				# Restore from decompressed file.
1353				require Compress::Zlib;
1354				require File::Slurp;
1355				my $file = $this->{-file};
1356				my $origfile = $this->{-origfile};
1357				my $tmpfile = $this->{-tmpfile};
1358				my $lines_ref = File::Slurp::read_file($tmpfile, scalar_ref=>1)
1359				or confess "$err: Unable to read temp file '$file' ".
1360				"for re-compression; $!.\n";
1361				my $contents = Compress::Zlib::memGzip($lines_ref)
1362				or confess "$err: Unable to gzip file '$file'.\n";
1363				File::Slurp::write_file($origfile, \$contents)
1364				or confess "$err: Unable to over-write file '$origfile'; $!.\n";
1365				unlink $tmpfile
1366				or carp "$warn: Error unlinking temp file '$tmpfile'; $!.\n";
1367				$this->{-file} = $origfile;
1368				$this->{-tmpfile} = undef;
1369				print "(Re-compressed '$tmpfile' to '$origfile'.)\n"
1370				if $verbose;
1371				}
1372
1373				if(! $robust) {
1374				handle_err($this,"$err/CLOSE: Failed",$opts)
1375				or return;
1376				}
1377
1378				if($warnem) {
1379				my ($err,@errs);
1380				while(&ffgmsg($err)) { push @errs,$err; }
1381				if(@errs) {
1382				carp "$warn/close: These messages were left on the error stack:\n".
1383				"=== \t".join("\n=== \t",@errs)."\n";
1384				}
1385				}
1386
1387				$this->{-closed} = 1;
1388				undef $this->{-fileptr}; # ... in case there's a destroy method in CFITSIO
1389
1390				return 1;
1391				}
1392
1393				sub readkey {
1394				my ($this,$opts,@args) = get_std_args(@_);
1395				my $name = shift @args;
1396				my ($hdunum,$num,$full,%def);
1397
1398				$hdunum = hdunum($this,$opts->{hdunum}) or return;
1399
1400				$name \|\|= $opts->{name} \|\| $opts->{key};
1401				$full = $opts->{full};
1402
1403				if($name =~ /^\s\d+\s$/) { $num = $name; $name = undef; }
1404
1405				@def{qw(name value comment type unit card index)} =
1406				read_key(fp($this),$name,$num,statr($this));
1407				handle_err($this,"$err/READKEY: Attempt to read $name failed", $opts)
1408				or return;
1409
1410				return $full ? \%def : $def{value};
1411				}
1412
1413				# Get the size of an IMAGE extension
1414				sub imsize {
1415				my ($this,$opts,@args) = get_std_args(@_);
1416				my $hdunum = shift @args;
1417				my $nelems = 0;
1418				my $nbytes = 0;
1419				my ($tp);
1420
1421				$hdunum = hdunum($this,$hdunum \|\| $opts->{hdunum}) or return;
1422
1423				($nelems,$nbytes) = get_im_size(fp($this),statr($this));
1424				handle_err($this,"$err/IMSIZE",$opts) or return;
1425
1426				return wantarray ? ($nelems,$nbytes,$nbytes*$nelems) : $nelems;
1427				}
1428
1429				# Get the size of an ASCII or binary table extension
1430				sub tblsize {
1431				my ($this,$opts,@args) = get_std_args(@_);
1432				my $hdunum = shift @args;
1433				my ($nrows,$ncols);
1434
1435				$hdunum = hdunum($this,$hdunum \|\| $opts->{hdunum}) or return;
1436
1437				($ncols,$nrows) = get_tbl_size(fp($this),statr($this));
1438				handle_err($this,"$err/TBLSIZE",$opts) or return;
1439
1440				return wantarray ? ($ncols,$nrows) : $nrows;
1441				}
1442
1443				# Get a single column value by column number from the current hdu.
1444				# This routine is bimorphic; if the "outdata" option is specified, it will
1445				# write rather than read.
1446				sub read1tblcolbynum {
1447				my ($this,$opts,@args) = get_std_args(@_);
1448				my $col = shift @args;
1449				my ($fp,$hdunum,$state,$iostate,$coldata,$row);
1450				my ($use,$outdata,$writing,$reading);
1451
1452				$fp = fp($this);
1453
1454				$hdunum = hdunum($this,$opts->{hdunum}) or return;
1455
1456				$col \|\|= $opts->{col} \|\| $opts->{colnum};
1457				$outdata= $opts->{outdata};
1458				# Default the state structure to the last one saved if none specified,
1459				# or to a new, anonymous, blessed structure.
1460				# $state = $opts->{state} \|\| $this->{-hdus}[$hdunum-1]{-iostate} \|\| {};
1461				$state = $opts->{state} \|\| iostate($this,{_ref=>1}) \|\| {};
1462				# $this->{-hdus}[$hdunum-1]{-iostate} = $state; # Save it to object instance
1463				iostate($this,{new=>$state});
1464
1465				$writing = defined $outdata;
1466				$reading = ! $writing;
1467				$use = $writing ? "WR1TBLCOL" : "RD1TBLCOL";
1468
1469				# Initialize column state data.
1470				$state->{hdunum} = $hdunum;
1471				$iostate = $state->{cols}[$col] \|\|= {}; # Initialize column-specific data
1472
1473				# Clear EOF flag if a specific row has been requested.
1474				if(defined $opts->{row}) { $iostate->{EOF} = 0; }
1475
1476				# Make a copy of the options so we can change them if need be
1477				my $myopts = {%$opts};
1478				# ... here for example ...
1479				if($writing) {
1480				# Put the output data in the correct form
1481				$myopts->{outdata} = ($myopts->{packed}
1482				? (ref($outdata)
1483				? $outdata
1484				: \ $outdata)
1485				: $outdata);
1486				# A scalar ref must be packed data (right?)
1487				$myopts->{packed} = 1 if ref($outdata) =~ /scalar/i;
1488				}
1489
1490				# Get/put the packed data for one column and all specified rows.
1491				$coldata = get_tbl_col_packed($fp,$col,$myopts,$iostate,statr($this));
1492				# Check for success.
1493				if(status($this) <= 0 && $iostate->{EOF}) { return 0; } # EOF
1494				elsif (! handle_err($this,"$err/$use",$myopts)) { return; } # Error
1495
1496				if($reading) {
1497				my $data = [];
1498				# Reading data
1499				# Do we want the data packed or unpacked?
1500				if(! $iostate->{packed}) {
1501				# Unpack the data
1502				my $tmplt = $iostate->{pack1row};
1503				my $rowsz = $iostate->{rowsize};
1504				$iostate->{packed} = 0;
1505				# Row-ize the data (i.e. break into rows)
1506				#print "Breaking coldata (len=".length($$coldata).")".
1507				# " into $iostate->{nrows} of $rowsz bytes.\n".
1508				# "Unpack template = '$tmplt'\n"; #####
1509				$data = [];
1510				for my $i (0..($iostate->{nrows}-1)) {
1511				my @this = unpack($tmplt,substr($$coldata,$i*$rowsz,$rowsz));
1512				if($iostate->{coltype}=~/^[cm]$/i) { @this = c_new(@this); }
1513				if(@this > 1 \|\| $iostate->{var}) { push @$data,\@this; }
1514				else { push @$data,$this[0]; }
1515				}
1516				# print "--- ",join(",",@$data),"\n";
1517				} else {
1518				# Keep data packed
1519				$data = $coldata;
1520				}
1521				return $data;
1522				} else {
1523				# Writing data
1524				return 1;
1525				}
1526				}
1527
1528				# Remove and rename columns in one go, write results to new table
1529				sub reform_tbl {
1530	3	0.01492	0.00497	use vars (%FITSIO::reform::info); # spent 62µs making 1 call to vars::import
1531				check_sig(';$$$',\@_) or confess;
1532				my ($this,$opts,@args) = get_std_args(@_);
1533				my ($infile,$outfile);
1534				if(! ref $this) {
1535				$infile = shift(@args) \|\| $opts->{oldfile};
1536				} else {
1537				$infile = $this->file;
1538				}
1539				$outfile = shift(@args) \|\| $opts->{newfile};
1540				my $hdunum = $opts->{hdunum} \|\| 2;
1541				my $nocopy = $opts->{norows};
1542				my $keepcols= $opts->{keep};
1543				$keepcols = undef if ref($keepcols) && ! @$keepcols;
1544				my $rmcols = $opts->{rm};
1545				$rmcols = undef if ref($rmcols) && ! @$rmcols;
1546				my $mvcols = $opts->{mv};
1547				my $addcols = $opts->{add};
1548				my $select = $opts->{select} \|\| ''; # FITSIO row selection string
1549				my $reformpkg=$opts->{reformpkg} \|\| "FITSIO::reform";
1550				my $info = $opts->{info} \|\| \%FITSIO::reform::info;
1551				my $band = $opts->{band};
1552				my $close = $opts->{close};
1553				my $data = $opts->{data};
1554				my $verbose = $opts->{verbose} \|\| 0;
1555				my $err = "*** $0/FITSIO/REFORM";
1556				my $warn= "=== $0/FITSIO/REFORM";
1557				print "FITS Reform ...\n" if $verbose;
1558				confess "$err: Both cols and rmcols specified.\n"
1559				if $keepcols && $rmcols;
1560				confess "$err: Keepcols not an array ref.\n"
1561				if $keepcols && ref($keepcols) !~ /array/i;
1562				confess "$err: Rmcols not an array ref.\n"
1563				if $rmcols && ref($rmcols) !~ /array/i;
1564				my $addstr= '';
1565				my (@addcols,@addxcols,@addxsubs);
1566				my (%inhdr);
1567				# Add to available info to general info structure
1568				@{$info}{qw/filename fitshdr/} = ($infile, \%inhdr);
1569				++$info->{filenum};
1570				$info->{band} \|\|= $band;
1571				if($addcols) {
1572				# Construct add column string and handle extended syntax for
1573				# more general
1574				confess "$err: Add column type '$addcols' ".
1575				"not an array ref.\n"
1576				if ref($addcols) !~ /array/i;
1577				confess "$err: Add column array spec not paired.\n"
1578				if @$addcols % 2 != 0;
1579				while(@$addcols) {
1580				my ($k,$v) = (shift(@$addcols),shift(@$addcols));
1581				print " Addcol: $k=>'$v'\n"
1582				if $verbose && $verbose > 1;
1583				if(! ref $v && $v !~ /^\&/) {
1584				# Normal, CFITSIO extended file name syntax
1585				$addstr .= '; ' if $addstr;
1586				$addstr .= "$k=$v";
1587				push @addcols, $k=~/^([^(]*)/;
1588				} else {
1589				# Special syntax for general column computations
1590				$k =~ s/^\s$(.)$\s*$/$1/;
1591				my @newcols = split /\s,\s/, $k;
1592				# Add dummy entried for these columns
1593				for (@newcols) {
1594				$addstr .= '; ' if $addstr;
1595				$addstr .= "$_=0.0";
1596				}
1597				# Remember columns names added this way
1598				push @addcols, @newcols;
1599				push @addxcols, @newcols;
1600				# If $v isn't a reference, we need to resolve it to one
1601				my $vref = $v;
1602				my $vraw = $v;
1603				my @cols;
1604				if(! ref $vref) {
1605				$vraw =~ s/^\&//; # Remove sigil
1606				$vraw =~ s/$(.)$\s$// # Pull off opt. col list
1607				and
1608				@cols = split /\s,\s/,$1; # Save columns
1609				$vraw = $reformpkg."::$vraw" if $vraw!~/::/ && $reformpkg;
1610				$vref = eval "\\&$vraw";
1611				confess "$err: Couldn't compile sub ref '$vraw' ".
1612				"(from '$v').\n$@"
1613				if $@;
1614				}
1615				# Wrap, ready to go
1616				print " Newcols def: (".join(",",@newcols).
1617				") = $vraw(".join(",",@cols).") ($vref)\n"
1618				if $verbose && $verbose > 1;
1619				push @addxsubs,
1620				sub { my $rows = shift;
1621				my $rowix = shift;
1622				my $newrows = shift;
1623				my @vals;
1624				@vals = $vref->($rows,$rowix,$info,@cols)
1625				or confess "$err: $vraw failed".
1626				"(from '$v') at row index $rowix; ".
1627				"cols=/@cols/.\n";
1628				$newrows->{$newcols[$_]}[$rowix] = $vals[$_]
1629				for 0..$#newcols;
1630				return 1;
1631				};
1632				}
1633				}
1634				if($addstr) {
1635				$addstr = "[".($hdunum-1)."][col $addstr ; *]";
1636				}
1637				}
1638				if($select) {
1639				$select = (! $addstr ? "[".($hdunum-1)."]" : "")."[$select]";
1640				}
1641				print " On open, applying add column spec '$addstr'".
1642				" and selection spec '$select' ...\n"
1643				if ($addstr \|\| $select) && $verbose;
1644				# Open both files
1645				print " Opening input file '$infile' and output file '$outfile' ...\n"
1646				if $verbose;
1647				my $in = $this->new($infile.$addstr.$select)
1648				or return;
1649
1650				if($in->size({hdunum=>$hdunum}) <= 0) {
1651				warn "$warn: No rows in '$infile. Returning early; no file created.\n";
1652				return 0;
1653				}
1654
1655				my $out = $this->new($outfile, {like => $in,
1656				mode => 'new',
1657				verbose => $verbose>1})
1658				or return;
1659				# Read input headers from both HDUs
1660				%inhdr = ( $in->keyhash({hdunum=>$hdunum}), $in->keyhash({hdunum=>1}) );
1661				handle_err($out,"$err: Attempt to read headers failed", $opts)
1662				or return;
1663				# Establish columns to be in the output file
1664				my @extant = $in->colnames({hdunum=>$hdunum});
1665				my %rm = map { (lc($_)=>1) } @{ $rmcols \|\| [] };
1666				$keepcols = [ grep { ! $rm{lc $_} } @extant ] if ! $keepcols;
1667				my %keep = map { (lc($_)=>1) } (@{ $keepcols \|\| [] }, @addcols);
1668				my @keep = grep { $keep{lc $_}} @extant;
1669				my @delete = grep {! $keep{lc $_}} @extant;
1670				my $nrows;
1671				if(! $nocopy) {
1672				if(! $data) {
1673				# Read data for needed columns
1674				print " Reading data ...\n" if $verbose;
1675				$data = $in->readcol('*',{hdunum=>$hdunum});
1676				handle_err($out,"$err: Attempt to read columns failed", $opts)
1677				or return;
1678				$nrows = $in->size();
1679				} else {
1680				$nrows = @{ $data->{(keys %$data)[0]} };
1681				}
1682				print " ... read $nrows rows.\n" if $verbose;
1683				}
1684				# Remove unwanted columns
1685				if(@delete) {
1686				print " Deleting ".@delete." columns.".($verbose>1?" @delete":"").
1687				" ...\n"
1688				if $verbose;
1689				$out->rmcols(\@delete,{hdunum=>$hdunum});
1690				handle_err($out,"$err: Attempt to remove columns failed", $opts)
1691				or return;
1692				}
1693				if($data) {
1694				# Write data
1695				print " Rewriting data ...\n" if $verbose;
1696				my $outdata = { map { ($_ => $data->{$_}) } @keep };
1697				$out->writecols($outdata,{hdunum=>$hdunum});
1698				handle_err($out,"$err: Attempt to write columns failed", $opts)
1699				or return;
1700				}
1701				if($mvcols) {
1702				# Rename columns
1703				# This is klugy and ugly
1704				print " Renaming columns ...\n" if $verbose;
1705				my %colnums = $out->colnums(\@keep);
1706				# Downcase column names
1707				while(my ($k,$v)=each %colnums) { $colnums{lc $k} = $v; }
1708				for my $newcol (sort keys %$mvcols) {
1709				my $oldcol = $mvcols->{$newcol};
1710				if(! $keep{lc $oldcol}) {
1711				confess "$err: Attempt to rename ".
1712				"non-existent column '$oldcol'.\n";
1713				}
1714				if(! $newcol \|\| $newcol =~ /[`\^!\*;,'"=]/ \|\|
1715				length($newcol) > 69) {
1716				confess "$err: Attempt to rename ".
1717				"column '$oldcol' to illegal '$newcol'.\n";
1718				}
1719				my $ttype = "TTYPE".$colnums{lc $oldcol};
1720				print " $oldcol($ttype) -> $newcol}\n" if $verbose > 1;
1721				$out->key([[$ttype => $newcol]],{hdunum=>2});
1722				handle_err($out,"*** FITSIO/REFORM: Attempt to ".
1723				"update key '$ttype' to '$newcol' failed", $opts)
1724				or return;
1725				}
1726				my $meta = $out->hdumeta();
1727				handle_err($out,"$err: Attempt to ".
1728				"resync HDU failed", $opts)
1729				or return;
1730				$out->{-hdus}[$hdunum-1] = $meta;
1731				}
1732				if($data && @addxsubs) {
1733				print " Populating new columns @addxcols ...\n" if $verbose;
1734				my %newdata;
1735				for my $ix (0..$out->size-1) {
1736				$info->{rownum}++;
1737				for my $subs (@addxsubs) {
1738				$subs->($data,$ix,\%newdata);
1739				}
1740				}
1741				$out->writecols(\%newdata,{hdunum=>$hdunum,row=>1});
1742				handle_err($out,"$err: Attempt to write new columns failed", $opts)
1743				or return;
1744				}
1745
1746				$out->end if $close;
1747
1748				print "FITS Reform complete.\n" if $verbose;
1749				return $out;
1750				}
1751
1752				#
1753				# Lower-level routines. Generally they don't do error handling but leave it
1754				# to higher level routines.
1755				#
1756				# Alot of these are so trivial they're just silly. We could reduce the line
1757				# count of this module by removing all the routines that don't really afdd any
1758				# value.
1759				#
1760
1761				# Get the current hdu number
1762				sub get_curr_hdu {
1763				my $fp = shift;
1764				my $statr = shift;
1765
1766				return ffghdn($fp,undef);
1767				}
1768
1769				sub open_file {
1770				my $file = shift;
1771				my $rmode = shift;
1772				my $overwrite = shift;
1773				my $statr = shift;
1774				my ($fp);
1775
1776				return if $$statr>0;
1777
1778				if($rmode eq 'create') { # Open file for writing, or create a new file
1779				$file = $overwrite ? "!$file" : $file;
1780				ffinit($fp,$file,$$statr);
1781				} else { # Open extant file
1782				ffopen($fp,$file,$rmode,$$statr);
1783				}
1784
1785				return $fp;
1786				}
1787
1788				# Get image size
1789				sub get_im_size {
1790				my $fp = shift;
1791				my $statr = shift;
1792				my ($nelems,$nbytes,$naxis,$naxes,$bpix);
1793				my $comment;
1794				my $tp = get_hdu_type($fp,$statr);
1795				return if $tp && $tp ne 'IMAGE';
1796
1797				($naxis,$naxes) = get_im_dim($fp,$statr);
1798				return if $$statr>0;
1799				$nelems = $naxis ? 1 : 0;
1800				for my $nax (@$naxes) { $nelems *= $nax; }
1801				if(wantarray) {
1802				ffgkyj($fp,"BITPIX",$bpix,$comment,$$statr);
1803				return if $$statr>0;
1804				$nbytes = abs($bpix)/8;
1805				# print "Returning $nelems,$nbytes,$naxis,$naxes,$bpix\n";
1806				return ($nelems,$nbytes,$naxis,$naxes,$bpix);
1807				}
1808				return $nelems;
1809				}
1810
1811				sub get_im_dim {
1812				my $fp = shift;
1813				my $statr = shift;
1814				my ($naxis,$naxes) = (0,[]);
1815				# print "ffgidm\n";
1816				ffgidm($fp,$naxis,$$statr);
1817				# Extremely odd; this has to be here or ffgisz fails with "out of memory".
1818				# print "";
1819				ffgisz($fp,$naxes,$$statr);
1820				return if $$statr > 0;
1821				# print "$naxis,@$naxes\n";
1822				return ($naxis,$naxes);
1823				}
1824
1825				sub resize_img {
1826				my $fp = shift;
1827				my $naxes = shift;
1828				my $bpix = shift;
1829				my $statr = shift;
1830				my $naxis = @$naxes;
1831				$bpix \|\|= getbpix($fp,$statr);
1832				return if $$statr > 0;
1833				ffrsim($fp,$bpix,$naxis,$naxes,$$statr);
1834				return if $$statr > 0;
1835				return 1;
1836				}
1837
1838				# Get size of an ASCII or binary table
1839				sub get_tbl_size {
1840				my $fp = shift;
1841				my $statr = shift;
1842				my ($nrows,$ncols,$tp);
1843
1844				$tp = get_hdu_type($fp,$statr);
1845				return if $tp !~ /TBL$/;
1846
1847				ffgnrw($fp,$nrows,$$statr);
1848				ffgncl($fp,$ncols,$$statr);
1849
1850				return if $$statr>0;
1851
1852				return wantarray ? ($ncols,$nrows) : $nrows;
1853				}
1854
1855				# Get offsets of header start and data start and end for the current HDU
1856				sub get_hdu_offsets {
1857				my $fp = shift;
1858				my $statr = shift;
1859				my ($hduoff,$datastartoff,$dataendoff);
1860				return if $$statr>0;
1861				ffghof($fp,$hduoff,$datastartoff,$dataendoff,$$statr);
1862				return if $$statr>0;
1863
1864				return wantarray ? ($hduoff,$datastartoff,$dataendoff) : $datastartoff;
1865				}
1866
1867				sub normalize_cols {
1868				my $fp = shift;
1869				my $col = shift;
1870				my $statr = shift;
1871				my (%cols,@order);
1872
1873				if(defined $col && $col ne "") {
1874				# Get col number from COLUMN, which can be either a number or a name.
1875				my @cols;
1876				if(ref($col) && ref($col) ne "ARRAY") {
1877				handle_err(10000,
1878				"$err/NORMCOL: Column spec '$col' not useful");
1879				return;
1880				}
1881				@cols = ref($col) ? @$col : ($col);
1882				for my $col (@cols) {
1883				# print "--- Normalizing column $col ...\n"; #####
1884				if($col =~ m/^\d+$/) {
1885				# Column is digits: take it as a numeric column number.
1886				# Make the column number less likely to conflict with a
1887				# column name, but still parseable by strtol.
1888				$col = "+0000000$col";
1889				} else {
1890				# Otherwise: take it as a column name or pattern.
1891				# If the name is surrounded by quotes, strip them.
1892				$col =~ s/^[''""](.*)[''""]$/$1/;
1893				}
1894				# Get the (set of) column number(s) for the names name(s),
1895				# or vice versa.
1896				my ($newcols,$order) = get_col_num($fp,$col,$statr);
1897				if(! defined $newcols \|\| ! keys %$newcols) {
1898				handle_err(10000,
1899				"$err/NORMCOL: Column spec '$col' did not match");
1900				return;
1901				}
1902				push @order,grep ! defined $cols{$_}, @$order;
1903				%cols = (%cols,%$newcols);
1904				handle_err($$statr,"$err/NORMCOL") or return;
1905				# print " Normalized to ".join(",",%cols)."\n"; #####
1906				}
1907				} else {
1908				# No column is defined. This means do all columns.
1909				my ($newcols,$order) = get_col_num($fp,"*",$statr);
1910				handle_err($$statr,"$err/NORMCOL") or return;
1911				@order = @$order;
1912				%cols = %$newcols;
1913				}
1914
1915				return wantarray ? (\%cols,\@order) : \%cols;
1916				}
1917
1918				# Get full info about a column in the current HDU based on the column number
1919				sub get_col_info {
1920				my $fp = shift;
1921				my $col = shift;
1922				my $statr = shift;
1923				my $hdutype = get_hdu_type($fp,$statr);
1924				my ($ttype,$tform,$tunit,$tdisp);
1925				my ($type,$tbcol,$tzero,$tscal,$tnull,$repeat,$val,$com,
1926				$nrows,$ncols,$naxes,$dtype,$unpk1);
1927				my ($naxis,$size,$bitpix);
1928
1929				return if $$statr>0;
1930
1931				if($hdutype eq 'BINARY_TBL') {
1932				ffgbcl($fp,$col,$ttype,$tunit,$tform,$repeat,
1933				$tscal,$tzero,$tnull,$tdisp,$$statr);
1934				ffbnfm($tform,$dtype,undef,undef,$$statr);
1935				$type = dcoltypename($dtype);
1936				# print "---- btform/dtype/type=$tform/$dtype/$type/\n"; ######
1937				} elsif ($hdutype eq 'ASCII_TBL') {
1938				ffgacl($fp,$col,$ttype,$tbcol,$tunit,$tform,
1939				$tscal,$tzero,$tnull,$tdisp,$$statr);
1940				ffasfm($tform,$dtype,undef,undef,$$statr);
1941				$type = dcoltypename($dtype);
1942				# print "---- atform/type=$tform/$type/\n"; ######
1943				} else { # IMAGE
1944				# This means get_std_keys is called twice per image header during
1945				# startup, but that's probably not so bad. It was the easiest way
1946				# to get the info.
1947				my $std = get_std_keys($fp,$statr);
1948				$naxis = $std->{NAXIS};
1949				$naxes = $std->{NAXES}; # Array ref
1950				$tzero = $std->{BZERO};
1951				$tscal = $std->{BSCALE};
1952				$tnull = $std->{BLANK};
1953				$ncols = $naxes->[0];
1954				$nrows = $naxes->[1];
1955				$bitpix= $std->{BITPIX};
1956				$type = $tform = {8=>'B', 16=>'I', 32=>'J', -32=>'E',
1957				-64=>'D'}->{$std->{BITPIX}};
1958				}
1959
1960				($ncols,$nrows) = get_tbl_size($fp,$statr); # Just for convenience
1961
1962				return if $$statr > 0;
1963
1964				$size = {'B'=>1, 'I'=>2, 'J'=>4, 'E'=>4, 'F'=>4, 'G'=>4, 'D'=>8,
1965				'L'=>1, 'X'=>1, 'C'=>8, 'M'=>16,'A'=>1}->{$type} \|\| 0;
1966
1967				$unpk1 = pcoltype($type,$repeat,$size);
1968
1969				if(defined $ttype && $ttype ne "" && $ttype !~ /^ +$/) {
1970				# Treat the comment to the ttype card as a brief description of the col
1971				$$statr = ffgkey($fp,"TTYPE$col",$val,$com,$$statr);
1972				return if $$statr > 0;
1973				}
1974
1975				return {name=>$ttype, unit=>$tunit, form=>$tform, repeat=>$repeat,
1976				begcol=>$tbcol,scale=>$tscal, zero=>$tzero, disp=>$tdisp,
1977				num=>$col, desc=>$com, nrows=>$nrows, ncols=>$ncols,
1978				blank=>$tnull, naxis=>$naxis, naxes=>$naxes, size=>$size,
1979				type=>$type, bitpix=>$bitpix,dtype=>$dtype, tmpl8=>$unpk1};
1980				}
1981
1982				sub get_all_col_info {
1983				my ($fp,$statr) = @_;
1984				my ($nrows,$ncols);
1985				my (@cols);
1986				return if $$statr > 0;
1987				my $type = get_hdu_type($fp,$statr);
1988				return if $$statr > 0;
1989				($ncols,$nrows) = $type eq 'IMAGE' ? (0,1) : get_tbl_size($fp,$statr);
1990				for (1..$ncols) {
1991				my $colinfo = get_col_info($fp,$_,$statr);
1992				return if $$statr > 0;
1993				push @cols,$colinfo;
1994				}
1995				return \@cols;
1996				}
1997
1998
1999
2000				# Get a column number based on a name. In an array context a hash is returned
2001				# providing potentially many colnum=>colname pairs if the 'name' passed in is
2002				# a template (pattern) using the '*', '?', '#' meta-characters. A call of
2003				# '*' will return all column names and numbers. In a scalar context, only
2004				# a single unique match is allowed; multiple matches or no matches
2005				# constitute an error.
2006				sub get_col_num {
2007				my $fp = shift;
2008				my $name = shift;
2009				my $statr = shift;
2010				my (@colnums,@colnames,%colnames);
2011				my ($colnum,$colname);
2012				my (%colinfo);
2013
2014				return if $$statr > 0;
2015
2016				#print "Name='$name', stat=$$statr\n"; #####
2017
2018				do {
2019				ffgcnn($fp,CASEINSEN,$name,$colname,$colnum,$$statr);
2020				#print " ffgcnn returned $fp,caseinsen=".CASEINSEN.
2021				# ",'$name',$colname,$colnum = $$statr ".
2022				# "(=?".COL_NOT_FOUND."/".COL_NOT_UNIQUE.")\n"; #####
2023
2024				# Check for errors
2025				$$statr = -10001, return
2026				if $$statr == COL_NOT_FOUND && ! wantarray;
2027
2028				handle_err($$statr, "$err/COLNUM: Column template '$name' not unique"),
2029				return
2030				if $$statr == COL_NOT_UNIQUE && ! wantarray;
2031
2032				handle_err($$statr,
2033				"$err/COLNUM: Column template '$name' produced some ".
2034				"terrible error"),
2035				return
2036				if $$statr > 0 && $$statr != COL_NOT_FOUND &&
2037				$$statr != COL_NOT_UNIQUE;
2038
2039				if($$statr != COL_NOT_FOUND) {
2040				# Got a column to add
2041				#print " name='$colname' number='$colnum'\n"; #####
2042
2043				push @colnums, $colnum;
2044				push @colnames,(defined $colname && $colname ne ""
2045				? $colname
2046				: "#$colnum"
2047				);
2048				}
2049
2050				} while($$statr == COL_NOT_UNIQUE);
2051
2052				$$statr = 0 if $$statr < 10000;
2053
2054				@colinfo{@colnums} = @colnames;
2055
2056				return wantarray ? (\%colinfo,\@colnums) : \%colinfo;
2057				}
2058
2059				sub get_hdu_meta {
2060				my $fp = shift;
2061				my $opts = shift \|\| {};
2062				my $statr = shift;
2063
2064				return if $$statr > 0;
2065
2066				my ($full,$merge,$hdunum) = @{$opts}{qw(full merge hdunum)};
2067				my ($meta);
2068
2069				if(defined $hdunum && (ref($hdunum) \|\| $hdunum eq '*')) {
2070				my @hdus;
2071				my %myopts = %$opts;
2072				if($hdunum eq '*') {
2073				my $n = get_num_hdus($fp,$statr);
2074				$hdunum = [1..$n];
2075				}
2076				for my $i (@$hdunum) {
2077				$myopts{hdunum} = $i;
2078				$meta = get_hdu_meta($fp,\%myopts,$statr);
2079				handle_err($$statr,"$err/GETMETA: Error on HDU $i",$opts)
2080				or return;
2081				push @hdus,$meta;
2082				}
2083				return \@hdus;
2084				} elsif($hdunum) {
2085				move_to_hdu($fp,$hdunum,$statr);
2086				}
2087
2088				my $nkeys = get_num_keys($fp,$statr);
2089				my $nhdus = get_num_hdus($fp,$statr);
2090				my $tp = get_hdu_type($fp,$statr);
2091				my ($nm,$v) = get_hdu_name($fp,$statr);
2092				my $i = get_curr_hdu($fp,$statr);
2093				if(! $nm && $i == 1) { $nm = "PRIMARY"; } # 1st is the PRIMARY
2094				my $std = get_std_keys($fp,$statr); # Get standard keys
2095				# Get more complete, easier to use column/pixel info
2096				my $colinfo;
2097				$colinfo = get_all_col_info($fp,$statr) if $full;
2098				# For table HDUs, index the column names and look for duplicates
2099				my $colix = {};
2100				my $colname = [];
2101				if($colinfo && @$colinfo && $tp =~ /tbl/i) {
2102				my %there;
2103				for (@$colinfo) {
2104				if($there{$_->{name}}++) {
2105				carp "$warn/GETHDUMETA: Column '$_->{name}' in HDU #$i has a ".
2106				"duplicate name";
2107				next; # Preserve the first one
2108				}
2109				$colix->{$_->{name}} = $_->{num};
2110				$colname->[$_->{num}] = $_->{name};
2111				}
2112				}
2113				my $hdu;
2114				$hdu = get_all_keys($fp,$opts,$statr) if $full;
2115				my ($nelems,$size,$naxis,$naxes,$bpix) = get_im_size($fp,$statr);
2116				my ($nrows,$ncols) = get_tbl_size($fp,$statr);
2117
2118				handle_err($$statr,
2119				"$err: Read of header info from HDU $i failed")
2120				or return; # Will only fail/return if $stat > 0
2121
2122				return {
2123				-nhdus=>$nhdus, -nkeys=>$nkeys,
2124				-hdunum=>$i,-hdutype=>$tp,-hduname=>$nm,
2125				-hduver=>$v\|\|"", -hdu=>$hdu, -info=>$colinfo,
2126				-nelems=>$nelems, -elemsz=>$size, -naxes=>$naxes,
2127				-nrows=>$nrows, -ncols=>$ncols,
2128				-colnums=>$colix, -colnames=>$colname,
2129				-std=>$std
2130				};
2131				}
2132
2133				sub get_hdr_str {
2134				my $fp = shift;
2135				my $opts = shift \|\| {};
2136				my $statr = shift;
2137				my ($hdr,$nhdr);
2138				# I guess this one's not exported ...
2139				Astro::FITS::CFITSIO::fits_hdr2str($fp,1,$hdr="",$nhdr=0,$$statr);
2140				return $hdr;
2141				}
2142
2143				# Read a column value from the named rows in the current HDU. Column data is
2144				# returned packed to make this low-level routine as fast as possible.
2145				# Row and element numbering is from 1.
2146				# This routine is also used for writing data since basically the same set
2147				# of meta-data and preparation is required. This may make reading the code
2148				# a bit difficult. Sorry. I'm too lazy to write two routines. It's probably
2149				# false laziness too, just so you know I'm not claiming virtuousness here.
2150				sub get_tbl_col_packed {
2151				my $fp = shift;
2152				my $colnum = shift;
2153				my $opts = shift \|\| {};
2154				# This routine must be suppied with a valid scalar target for iostate.
2155				# Overwrite arg alias with new hash ref if not defined.
2156				my $iostate = ref($_[0])!~/hash/i ? ($_[0]={},shift) : shift;
2157				my $statr = shift;
2158				my ($packed,$append,$update,$outdata,$seq,$anynul,$naxis,$naxes,$ncharels,
2159				$dref,$all,$use,$writing,$reading,$skip,$type,$dtype);
2160				# Copies of iostate data.
2161				my (
2162				$row,$nrows,$var,$maxrows,$maxcols,$rowlen,$hdutype,
2163				$nelems,$coltype,$unpk1,$repeat,$width,$internaltype
2164				) =
2165				@{$iostate}{
2166				qw/row nrows var maxrows maxcols rowsize hdutype
2167				nelems coltype pack1row repeat width internaltype/
2168				};
2169
2170				return if $$statr>0;
2171
2172				if(! $hdutype) {
2173				$hdutype = get_hdu_type($fp,$statr);
2174				return if $$statr>0;
2175				$iostate->{hdutype} = $hdutype;
2176				}
2177				if($hdutype eq 'IMAGE') {
2178				carp "$err/$use: Requested table data from an image.\n";
2179				$$statr = 10000; # Error.
2180				return;
2181				}
2182
2183				# Get options
2184				$outdata = $opts->{outdata};
2185				$update = $opts->{update} \|\| $iostate->{update};
2186				$iostate->{update} = $update;
2187				$append = $opts->{append} \|\| $iostate->{append};
2188				$iostate->{append} = $append;
2189				$packed = $opts->{packed} \|\| $iostate->{packed};
2190				$iostate->{packed} = $packed;
2191				$type = $opts->{type};
2192
2193				# Reading or writing?
2194				$writing = defined $outdata;
2195				$reading = ! $writing;
2196				$iostate->{writing} = $writing;
2197				$use = $writing ? "PUTCOL" : "GETCOL";
2198
2199				$colnum \|\|= $iostate->{colnum};
2200
2201				if(! defined $colnum) {
2202				carp "$err/$use: No column number defined.\n";
2203				$$statr = 10000; # Error.
2204				return;
2205				}
2206
2207				if(defined $iostate->{colnum} && $colnum != $iostate->{colnum}) {
2208				carp "$err/$use: Requested column #$colnum disagrees with ".
2209				"internal column #$iostate->{colnum}.\n";
2210				$$statr = 10000; # Error.
2211				return;
2212				}
2213
2214				$iostate->{colnum} = $colnum; # Save column in meta-data
2215				{
2216				my ($colname) = get_col_num($fp,$colnum,$statr);
2217				return if $$statr>0;
2218				#print "$colnum => $colname->{$colnum}\n";
2219				$iostate->{name} = $colname->{$colnum}; # Save column name in meta-data
2220				}
2221
2222				# Establish which rows to read or write.
2223				$row = (defined $opts->{row} ? $opts->{row} : $row) \|\| 0;
2224				if(! defined $opts->{row}) { ++$row; $seq = 1; }
2225
2226				$skip = $opts->{skip}; # Not used ... yet.
2227
2228				if($reading) {
2229				if(! defined $maxrows \|\| $update) {
2230				($maxcols,$maxrows) = get_tbl_size($fp,$statr);
2231				return if $$statr>0;
2232				$iostate->{maxrows} = $maxrows;
2233				$iostate->{maxcols} = $maxcols;
2234				}
2235				$nrows = defined $opts->{nrows} ? $opts->{nrows} : $nrows;
2236				if(! defined $nrows) { $iostate->{nrows} = $nrows = $maxrows-$row+1; }
2237				if($nrows < 0) {
2238				# Read abs($nrows) or whatever's left, whichever is smaller
2239				$nrows = abs($nrows);
2240				my $nleft = $maxrows - $row + 1;
2241				$nrows = $nrows > $nleft ? $nleft : $nrows;
2242				}
2243				# $nrows == 0 is valid and leads to an early return.
2244				if($nrows == 0) { $iostate->{nrows} = undef; $nrows = 0; }
2245				else { $iostate->{nrows} = $nrows; }
2246
2247				if($row > $maxrows) {
2248				# Trying to read past EOF. Could be OK on first encounter
2249				# during sequential read, otherwise an error.
2250				my $retval;
2251				#print "--- seq=$seq, EOF=$iostate->{EOF}, ".
2252				# "row=$row, nrows=$nrows\n"; #####
2253				$iostate->{nrows} = $iostate->{nelems} = $iostate->{repeat} = 0;
2254				if($seq && ! $iostate->{EOF}) {
2255				$retval = "";
2256				$$statr = -10000; # EOF but not an error.
2257				} else {
2258				carp "$err/$use: Read beyond EOF attempted, column $colnum.\n";
2259				$retval = undef;
2260				$$statr = 10000; # Error.
2261				}
2262				$iostate->{EOF} = 1;
2263				return $retval;
2264				}
2265				$iostate->{EOF} = 0;
2266				#print STDERR "--- row=$row, nrows=$nrows, maxrows=$maxrows\n";
2267				if($row+$nrows-1 > $maxrows) {
2268				# Reduce requested rows to those still available
2269				$nrows = $maxrows - ($row-1);
2270				$iostate->{nrows} = $nrows;
2271				}
2272				} # ... reading
2273
2274				if(! $nelems) { # Column details not yet pulled out
2275				my $thistype;
2276				ffgtcl($fp,$colnum,$thistype,$repeat,$width,$$statr);
2277				#print "---- $colnum,$thistype,$repeat,$width\n";
2278				return $$statr if $$statr>0;
2279				if($thistype < 0) { $var = 1; } # Var length vector
2280				$var \|\|= 0;
2281				$iostate->{var} = $var;
2282				$thistype = dcoltypename(abs($thistype));
2283				$internaltype = $iostate->{internaltype} = $thistype;
2284				# Set the output type to the input type unless overidden by the user
2285				$type = $thistype if ! $type;
2286				if($type eq 'A' && $width != 1) {
2287				# Some special processing so $repeat*$width is always
2288				# the column width in bytes. The FITS 'array of strings'
2289				# extension gets this wrong by, for example, returning
2290				# width=12, repeat=60 for an '60A12' specification. It
2291				# should be width=12, repeat=5.
2292				if($repeat != int($repeat/$width)*$width) {
2293				carp "$err/$use: Char array column #$colnum ".
2294				"has bad repeat/width comnbination '$repeat/$width'.\n";
2295				$$statr = 10000;
2296				return;
2297				}
2298				$repeat /= $width;
2299				}
2300				#print "--- Column $colnum, row $row: repeat=$repeat.\n"; ####
2301				}
2302				$coltype = $iostate->{coltype} = $type \|\| $internaltype;
2303				if($var && $nrows && $nrows > 1) {
2304				# Can only read one var row at a time, and can't write them yet
2305				carp "$err/$use: Var len column # $colnum can only be read/written ".
2306				"one row at a time, not $nrows rows.\n";
2307				$$statr = 10000;
2308				return;
2309				}
2310				if((! $nelems && $hdutype eq 'BINARY_TBL') \|\| $var) {
2311				# Get more detailed column info in case there's a TDIM spec
2312				ffgtdm($fp,$colnum,$naxis,$naxes,$$statr);
2313				return if $$statr>0;
2314				$iostate->{ndims} = $naxis;
2315				$iostate->{dims} = $naxes;
2316				}
2317				if($writing) {
2318				# More involved calc of number of rows to write.
2319				# Delayed to here because we need to have the $repeat count.
2320				if(! ref $outdata) {
2321				$nrows = 1;
2322				$repeat = 1;
2323				} elsif(ref($outdata)=~m/scalar\|lvalue/i) {
2324				$nrows = length($$outdata)/($repeat*$width);
2325				} elsif(ref($outdata)=~m/array/i) {
2326				$nrows = @$outdata;
2327				if($var) {
2328				if(ref($outdata->[0])=~m/array/i) {
2329				$repeat = @{$outdata->[0]};
2330				} elsif(ref($outdata->[0])=~m/scalar/i) {
2331				$repeat = length(${$outdata->[0]})/$width;
2332				}
2333				}
2334				} else {
2335				carp "$err/$use: Don't know what to make of row data '$outdata' ".
2336				"for column # $colnum.\n";
2337				$$statr = 10000;
2338				return;
2339				}
2340				$iostate->{nrows} = $nrows;
2341				if($nrows == 0) { return 1; }
2342				# print "For outdata '$outdata' nrows=$nrows, repeat=$repeat.\n";
2343				}
2344				$rowlen = colsize($coltype,$repeat,$width); # Length of one row
2345				$iostate->{repeat} = $repeat; # Num. elem.s per row
2346				$iostate->{width} = $width; # Width of one element
2347				$iostate->{rowsize} = $rowlen; # Length (bytes) of one row
2348				$nelems = $repeat*$nrows; # Total elements to be read/written
2349				$iostate->{nelems} = $nelems;
2350				# Compute the last row read for sequential reading so the next
2351				# read will pick up in the correct place.
2352				$iostate->{row} = $row + $nrows - 1;
2353				$iostate->{toprow} = $row;
2354				$iostate->{ninrow} = $repeat;
2355				$unpk1 = pcoltype($coltype,$repeat,$width);
2356				$iostate->{pack1row}= $unpk1; # Template to pack/unpack one row of data
2357				#print "--- Col=$colnum, row=$row, type=$coltype, ".
2358				# "repeat=$repeat, width=$width, nrows=$nrows, ".
2359				# "nelems=$nelems, ninrow=$iostate->{ninrow}, unpk1='$unpk1', ".
2360				# "rowlen=$rowlen, var=$var, writing=$writing\n"; #####
2361
2362				if($opts->{noscale}) {
2363				# Do not scale the data
2364				$iostate->{scale} = 0;
2365				fftscl($fp,$colnum,1.0,0.0,$$statr);
2366				return if $$statr>0;
2367				}
2368				### ffrdef requires a writeable file
2369				#elsif($opts->{scale}) {
2370				# # Scale the data. This is the default, so setting this means that
2371				# # previously you had set noscale, one assumes.
2372				# ffrdef($fp,$$statr); # Reread scale info from header
2373				# return if $$statr>0;
2374				#}
2375				if($reading) {
2376				# ================== Handle column input
2377
2378				# Allocate space for binary data
2379				my $buf = "~" x ($rowlen*$nrows);
2380				my $ref = \$buf;
2381
2382				if(! $nrows) { return $ref; } # Early return
2383
2384				# Init where we put the data. Slightly different for strings vs.
2385				# other packed data since multiple strings (nelems>1) will be returned
2386				# as an array of scalars rather than as one packed scalar.
2387				if($coltype eq 'A') {
2388				$dref = \ [("~" x $width) x $nelems]; # To hold an array of str
2389				} else {
2390				$dref = $ref; # To hold the packed scalar return data
2391				}
2392
2393				# All set up and ready to go. Read $nrows worth of data for
2394				# this column.
2395
2396				#print "ffgcv args = /".join("/ /",$coltype,dcoltype($coltype),
2397				# $colnum,$row,
2398				# $nelems,$dref,length($$dref))."/\n"; #####
2399
2400				# We don't let CFITSIO do the unpacking so we can unpack directly
2401				# into rows rather than chopping a long list of elements into
2402				# rows. This may be faster, or it may not.
2403				CFITSIO::PerlyUnpacking(0); # Using packed data, so suppress unpacking
2404				ffgcv($fp,dcoltype($coltype),$colnum,$row,1,$nelems,undef,
2405				$$dref,$anynul,$$statr);
2406				CFITSIO::PerlyUnpacking(1); # Re-enable auto-unpacking
2407
2408				return if $$statr > 0;
2409
2410				if($coltype eq 'A') {
2411				# Join the strings into a single string a simple
2412				# pack template can be used on all data types.
2413				$$ref = join("",map { pack("A$width",$_) } @$$dref);
2414				}
2415
2416				return $ref;
2417
2418				} else {
2419				# ================== Handle data output
2420
2421				my $dcoltype = dcoltype($coltype);
2422
2423				if(ref($outdata)=~/scalar/i && length($$outdata) != $rowlen*$nrows) {
2424				carp "$err/$use: Bad packed row length. Expected ".
2425				($rowlen*$nrows).", have ".length($$writing).".\n";
2426				$$statr = 10000;
2427				return;
2428				}
2429
2430				if(ref($outdata) =~ /scalar/i && $dcoltype == TSTRING) {
2431				### && $nelems>1) { # We don't seem to want this restriction
2432				# ffpcl doesn't seem to handle string column output the way one
2433				# would expect for multirow output. We apparently need to break it
2434				# up into a vector of strings of appropriate size.
2435				$outdata = [ unpack("a$rowlen" x $nrows,$$outdata) ];
2436				}
2437
2438				if(ref($outdata) =~ /array/i && @$outdata &&
2439				ref($outdata->[0]) =~ /scalar/i) {
2440				# For arrays of scalar refs, create one big packed string since
2441				# that's what the CFITSIO interface expects for this sort of thing.
2442				my $tmp = "";
2443				$tmp .= $$_ for @$outdata;
2444				$outdata = \$tmp;
2445				}
2446
2447				for ( ref($outdata)=~/array/i ? (@$outdata) :
2448				! ref($outdata) ? ($outdata) : () ) {
2449				if(! defined $_) {
2450				# Blanks
2451				if($dcoltype == TFLOAT \|\| $dcoltype == TDOUBLE) {
2452				$_ = "NaN";
2453				} elsif($dcoltype == TSTRING) {
2454				$_ = "";
2455				} else {
2456				$_ = 0;
2457				}
2458				}
2459				}
2460
2461				if(($dcoltype == TCOMPLEX \|\| $dcoltype == TDBLCOMPLEX) &&
2462				ref($outdata)!~/scalar/i) {
2463				# We must strip the Math::Complex values down to simple
2464				# 2 element array ref.s
2465				lol_c_unbless($outdata);
2466				}
2467
2468				# Here's the CFITSIO call.
2469				# I think this works like this:
2470				# - if $outdata is a scalar ref, assume it points to packed data,
2471				# - data in a scalar or a ref to an ND array is packed in ffpcl,
2472				# - anything else is an error.
2473				# XXXXXX
2474				#print "$coltype $dcoltype $colnum $row $iostate->{name} $nelems ".
2475				# "$outdata ".
2476				# (ref($outdata)=~/scalar/i?length($$outdata)." ":"-1 ")."\n";
2477				ffpcl($fp,$dcoltype,$colnum,$row,1,$nelems,$outdata,$$statr);
2478
2479				return if $$statr > 0;
2480
2481				return 1;
2482				}
2483				}
2484
2485				# Count the total number of elements in a ref to a lol.
2486				sub nlolels {
2487				my $lol = shift;
2488				my $n;
2489				for (@$lol) {
2490				if(ref($_) && ! c_isit($_)) { $n += nlolels($_); }
2491				else { ++$n; }
2492				}
2493				return $n;
2494				}
2495
2496				# Count the total number of elements in a ref to a lol.
2497				sub lol_c_unbless {
2498				my $lol = shift;
2499				my $n;
2500				for (@$lol) {
2501				if(ref($_) && ! c_isit($_)) { lol_c_unbless($_); }
2502				else { $_ = [c_split($_) ]; }
2503				}
2504				}
2505
2506				sub delete_tbl_rows {
2507				my $fp = shift;
2508				my $rows = shift;
2509				my $statr= shift;
2510				my (%rows);
2511				@rows{ (ref $rows ? @$rows : ($rows)) } = (); # Remove dups
2512				ffdrws($fp, [sort { $a<=>$b } keys %rows], scalar(keys %rows), $$statr);
2513				return if $$statr>0;
2514				return 1;
2515				}
2516
2517				sub delete_tbl_cols {
2518				my $fp = shift;
2519				my $cols = shift;
2520				my $statr= shift;
2521				my (%cols);
2522				return if $$statr > 0;
2523				@cols{ (ref $cols ? @$cols : ($cols)) } = (); # Remove dups
2524				for my $col (keys %cols) {
2525				my ($newcols,$order) = get_col_num($fp,$col,$statr);
2526				next if ! @$order;
2527				#print "--- $col -> @$order\n";
2528				ffdcol($fp, $_, $$statr) for @$order;
2529				return if $$statr > 0;
2530				}
2531				return if $$statr>0;
2532				return 1;
2533				}
2534
2535				# Get number of HDUs
2536				sub get_num_hdus {
2537				my $fp = shift;
2538				my $statr = shift; # status being carried along
2539				my $opts = shift \|\| {};
2540				my ($n);
2541
2542				ffthdu($fp,$n,$$statr);
2543				return if $$statr>0;
2544				return $n;
2545				}
2546
2547				# Move to an absolute hdu number 1..max-hdu. Return hdutype.
2548				sub move_to_hdu {
2549				my $fp = shift;
2550				my $hdunum = shift;
2551				my $statr = shift; # status being carried along
2552				my $opts = shift \|\| {};
2553				my $hdutype;
2554
2555				return if $$statr>0;
2556
2557				if(defined $hdunum) {
2558				ffmahd($fp,$hdunum,$hdutype,$$statr);
2559				} else {
2560				ffghdt($fp,$hdutype,$$statr);
2561				}
2562				return if $$statr>0;
2563
2564				return hdunames($hdutype);
2565				}
2566
2567				# Get hdu type of current hdu
2568				sub get_hdu_type {
2569				my $fp = shift;
2570				my $statr = shift; # status being carried along
2571				my $hdutype;
2572				ffghdt($fp,$hdutype,$$statr);
2573				return if $$statr>0;
2574				return hdunames($hdutype);
2575				}
2576
2577
2578				# Get extension name and version, if any
2579				sub get_hdu_name {
2580				my $fp = shift;
2581				my $statr = shift; # status being carried along
2582				my $opts = shift \|\| {};
2583				my ($nm ,$vrsn);
2584				my ($val,$com);
2585
2586				return if $$statr>0;
2587
2588				ffgkey($fp,"EXTNAME",$val,$com,$$statr);
2589				return if $$statr > 0 && $$statr != KEY_NO_EXIST;
2590				$val = "" if $$statr>0; # In case the keyword wasn't found
2591				$$statr = 0;
2592				($nm = $val) =~ s/^\s'(.)'\s*$/$1/;
2593				ffgkey($fp,"EXTVER",$val,$com,$$statr);
2594				return if $$statr > 0 && $$statr != KEY_NO_EXIST;
2595				$val = "" if $$statr>0;
2596				$$statr = 0;
2597				($vrsn = $val) =~ s/\s'(.)'\s*/$1/;
2598				return ($nm,$vrsn);
2599				}
2600
2601				# Read image data from current hdu into a buffer of arbitrary type
2602				sub get_impix {
2603				my $fp = shift;
2604				my $buf = shift;
2605				my $type = shift;
2606				my $noscale = shift;
2607				my $statr = shift;
2608				my ($npix,$pixsz) = get_im_size($fp,$statr);
2609				my $bpix = getbpix($fp,$statr);
2610				my $dtype;
2611				my $dummy=0;
2612
2613				return if ! $bpix \|\| ! $npix;
2614				return if $$statr > 0;
2615				$type \|\|= bpix2type($bpix);
2616				$dtype = dcoltype($type);
2617
2618				if($noscale) { ffpscl($fp,1.0,0.0,$$statr); }
2619
2620				if(! ref $buf) { $buf = \ my $spc; } # Init a scalar ref
2621				CFITSIO::PerlyUnpacking(0);
2622				ffgpv($fp,$dtype,1,$npix,0,$$buf,$dummy,$$statr);
2623				CFITSIO::PerlyUnpacking(1);
2624				return if $$statr>0;
2625				return $buf;
2626				}
2627
2628				# Write a packed string of pixel valuies, assumed to be the right size
2629				# and either of the type appropriate for the HDU, or the type specified/
2630				sub put_impix {
2631				my $fp = shift;
2632				my $buf = shift;
2633				my $type = shift;
2634				my $noscale = shift;
2635				my $statr = shift;
2636				my $bpix = getbpix($fp,$statr);
2637				my $npix = get_im_size($fp,$statr);
2638				my ($dtype,$pixlen);
2639
2640				return if $$statr > 0;
2641				if(! $bpix \|\| ! defined $npix) {
2642				carp "$err/PUTIMPIX: Bad BITPIX or NPIX returned ($bpix/$npix).\n";
2643				$$statr = 10000;
2644				return;
2645				}
2646				$type \|\|= bpix2type($bpix);
2647				$dtype = dcoltype($type);
2648				if(! defined $dtype) {
2649				carp "$err/PUTIMPIX: Type '$type' not known.\n";
2650				$$statr = 10000;
2651				return;
2652				}
2653				#$pixlen = abs($bpix)/8; # old, and busted?
2654				$pixlen = colsize($type); # new, and cool?
2655				#print "\n--- bpix=$bpix, bpixtype=",bpix2type($bpix),
2656				# " type=$type, dtype=$dtype, pixlen=$pixlen, ".
2657				# "npix=$npix, statr=$$statr.\n";
2658				if(length($$buf) != $pixlen*$npix) {
2659				carp "$err/PUTIMPIX: Buffer length ".length($$buf)." incorrect; ".
2660				"wanted ".($pixlen$npix)." ($pixlen$npix) for type $type.\n";
2661				$$statr = 10000;
2662				return;
2663				}
2664
2665				if($noscale) { ffpscl($fp,1.0,0.0,$$statr); }
2666
2667				CFITSIO::PerlyUnpacking(0);
2668				ffppr($fp,$dtype,1,$npix,$buf,$$statr);
2669				CFITSIO::PerlyUnpacking(1);
2670				return if $$statr > 0;
2671				return 1;
2672				}
2673
2674	1	9.1e-5	9.1e-5	my %bpixs = (&BYTE_IMG => 'B', &SHORT_IMG => 'I', &USHORT_IMG => 'I', # spent 245µs making 8 calls to Astro::FITS::CFITSIO::AUTOLOAD, avg 31µs/call
2675				&LONG_IMG => 'J', &ULONG_IMG => 'J', &LONGLONG_IMG => 'K',
2676				&FLOAT_IMG => 'E', &DOUBLE_IMG => 'D', );
2677
2678				sub bpix2type {
2679				my $bpix = shift;
2680				return $bpixs{$bpix+0};
2681				}
2682
2683				sub getbpix {
2684				my $fp = shift;
2685				my $statr = shift;
2686				my $bpix;
2687				ffgidt($fp,$bpix,$$statr);
2688				return if $$statr > 0;
2689				return $bpix;
2690				}
2691
2692				# Get optimal no. of table rows to read/write
2693				sub getoptrows {
2694				my $fp = shift;
2695				my $statr = shift;
2696				my $optrows;
2697				ffgrsz($fp,$optrows,$$statr);
2698				return if $$statr > 0;
2699				return $optrows;
2700				}
2701
2702
2703				# Take the header data from another FITSIO instance
2704				# and make a header definition suitable for use in create_hdus.
2705				# (Basically it strips '-' off the appropriate meta-data key names.)
2706				sub make_hdu_def_like {
2707				my $hdudef = shift;
2708
2709				if(ref($hdudef) =~ /array/i) {
2710				return [ map { make_hdu_def_like($_) } @$hdudef ];
2711				}
2712
2713				return {
2714				hdunum=>$hdudef->{-hdunum}, hduname=>$hdudef->{-hduname},
2715				hduver=>$hdudef->{-hduver}, hdutype=>$hdudef->{-hdutype},
2716				hdu=>make_hdudef_std($hdudef->{-hdu} \|\| [])
2717				# ^^^^^^^^^^^^^^ does nothing???
2718				};
2719				}
2720
2721				# Take a variety of ways of defining header cards and normalize them into
2722				# an array of standard definition hases ({name=>..., type=>..., value=>...})
2723				sub make_hdudef_std {
2724				my $hdu = shift;
2725				my $opts = shift \|\| {};
2726				my $undefvalok = $opts->{undefvalok};
2727				my (@in,@do);
2728				my $ix = 1000000; # Order index for card definitions
2729				my (@cards,$enum,$many,$name);
2730
2731				confess "$err/HDUSTD: HDU def.s not array ref."
2732				if ref($hdu) !~ /array/i;
2733
2734				return [] if ! @$hdu; # OK but empty
2735
2736				#print "$hdu, $hdu->[0], ",ref($hdu->[0]),"\n";
2737				#require Data::Dumper; Data::Dumper->import();
2738				#print Dumper($hdu);
2739
2740				if(ref($hdu->[0]) =~ /hash/i) {
2741				# Already in correct form, but it may be useful to assign types.
2742				for my $r (@$hdu) {
2743				if(! exists $r->{type} && ! commentp($r->{name}) &&
2744				exists $r->{value}) {
2745				my $com;
2746				($r->{type},$r->{value},$com) = val_to_typecom($r->{value});
2747				$r->{comment} = $com
2748				if $com &&
2749				(! defined $r->{comment} \|\| ! length $r->{comment});
2750				}
2751				}
2752				return $hdu;
2753				}
2754
2755				confess "$err/HDUSTD: Odd no. of HDU def.s elements."
2756				if ! ref($hdu->[0]) && (@$hdu)%2;
2757
2758				if(! ref($hdu->[0])) {
2759				# [key=>val,key=>val,...]
2760				my @tmp = @$hdu;
2761				push @cards, [shift(@tmp),shift(@tmp)] while @tmp;
2762				} else {
2763				if(@$hdu == 1) {
2764				my @tmp = @{$hdu->[0]};
2765				if(! ref $tmp[0]) {
2766				# [[key=>def,key=>def,...]]
2767				push @cards, [shift(@tmp),shift(@tmp)] while @tmp;
2768				} else {
2769				# [[def,def,def,...]]
2770				confess "$err/HDUSTD: HDU def.s missing 'name' key"
2771				if ! exists $tmp[0]{name};
2772				push @cards, [$tmp[0]{name}=>shift(@tmp)] while @tmp;
2773				}
2774				} else {
2775				# [[key=>val],[key=>val],...]
2776				@cards = @$hdu;
2777				}
2778				}
2779
2780				# Semi-deep-ish copy @cards to avoid altering the user's parameters
2781				for (@cards) {
2782				next if ! ref $_;
2783				$_ = [ @$_ ] if ref($_) =~ /array/i;
2784				}
2785
2786				#print Dumper \@cards;
2787
2788				for (@cards) {
2789				my ($key,$def) = @$_;
2790				(carp("$err/HDUSTD: Bad HDU card def: ".
2791				"key='".(defined $key?$key:'<undef>').
2792				"', def='".(defined $def?$def:'<undef>')."'"),
2793				return)
2794				if ! defined $key \|\| (! $undefvalok && ! defined $def); # Bad
2795				#print "----- '$key'=>'$def'\n"; ######
2796				# $def is a value or an ary of values (key=>value or key=>[value,...])
2797				# iff $def ...
2798				# - is not a reference, or
2799				# - is a complex number, or
2800				# - is an array ref.
2801				if(! defined $def \|\| ! ref($def) \|\| c_isit($def) \|\|
2802				ref($def) =~ /array/i) {
2803				# Only a value is provided. Later we'll determine its type and
2804				# overwrite $def with an appropriate full card definition
2805				#print " Card is a value only; key=$key, def=$def.\n"; ######
2806				$def={value=>$def};
2807				}
2808				# Now it's guarenteed to be a hashref with a (possibly partial) card
2809				# definition inside, or a ref. to an array of such def.s
2810				if(ref($def) =~ /array/i) {
2811				# if def is an array ref., we have multiple cards of the same name
2812				#print " Card '$key' is ".scalar(@$def)."-times multiple.\n"; ####
2813				@do = @$def;
2814				$many = 1;
2815				} elsif(ref($def->{value}) =~ /array/i) {
2816				# This is a pseudo-array card, with an array of values in the
2817				# 'value' slot. Duplicate the def. for all cards, but make the
2818				# value specific to each.
2819				#print " Card '$key' is an ".scalar(@{$def->{value}}).
2820				# " element array (of ".ref($def->{value}[0]).").\n"; ######
2821				if(defined $def->{name} && $def->{name} eq "NAXIS") {
2822				$def->{name}="NAXES"; # Special case
2823				}
2824				# The value for each element can be either a scalar value or
2825				# a hash ref of full card definitions (e.g. including a comment)
2826				@do = map { ref($_) ? {%$_} : {%$def, value=>$_} }
2827				@{$def->{value}};
2828				$many = 1;
2829				} else {
2830				# Just one, uncomplicated def
2831				#print " Card '$key' is a plain key=val pair\n"; #####
2832				@do = ($def);
2833				$many = 0;
2834				}
2835
2836				# Step through each definition and add any needed but excluded info
2837				$enum = 0;
2838				$name = $key;
2839				if($name eq 'NAXES') { $name = 'NAXIS'; } # Special case
2840				for my $r (@do) {
2841				#print "name=$key, val/com=/".
2842				# (defined $r->{value}?$r->{value}:"<undef>").
2843				# "/".(defined $r->{comment}?$r->{comment}:"<undef>")."/\n";
2844				# Is it an information-less card? Then skip it.
2845				next if (! $undefvalok && ! defined $r->{value}) &&
2846				! defined $r->{comment};
2847				# Is this a repeating card for which enumeration is wanted?
2848				if($many && ! commentp($key) && $key!~/[\s\d]$/) {
2849				++$enum;
2850				#print "Enumerating '$name' ($key) with $enum.\n"; #####
2851				$r->{name} = "\U$name$enum";
2852				}
2853				# Fill in more possibly missing info
2854				if( ! commentp($key) && ! defined $r->{value} && $undefvalok) {
2855				$r->{type} = 'A';
2856				$r->{value} = '<undef>';
2857				}
2858				if(! defined $r->{type} && ! commentp($key)) {
2859				my $com;
2860				($r->{type},$r->{value},$com) = val_to_typecom($r->{value});
2861				#print "--- /$key,$r->{type},$r->{value},$com/$r->{comment}/\n";
2862				$r->{comment} = $com
2863				if $com &&
2864				(! defined $r->{comment} \|\| ! length $r->{comment});
2865				}
2866				if(! defined $r->{name}) { $r->{name} = uc $name; }
2867				if(! defined $r->{index}){ $r->{index}= ++$ix; }
2868				if(commentp($key)) {
2869				if(! defined $r->{comment}) {
2870				$r->{comment} = $r->{value};
2871				}
2872				$r->{value} = $r->{type} = undef;
2873				}
2874				# if(! defined $r->{comment}) { $r->{comment} = ""; }
2875				# print "'$key': '$r->{name}' '$r->{type}' $r->{index}\n". #####
2876				# " '$r->{value}'\n" #####
2877				# ." '$r->{comment}'\n" #####
2878				# if $key eq 'COMMENT' #####
2879				# ; #####
2880				# Trim off white space from name
2881				$r->{name} =~ s/^\s(.?)\s*/$1/;
2882				# Trim off white space and outer quotes from value
2883				$r->{value} =~ s/^\s[''""](.?)[''""]\s*/$1/
2884				if defined $r->{value};
2885				# Add full, normalized card def.
2886				push @in,$r;
2887				}
2888				}
2889
2890				# Sort on index
2891				@in = map { $in[$_] } sort { $in[$a]{index} <=> $in[$b]{index} } 0..$#in;
2892
2893				return \@in;
2894				}
2895
2896				sub commentp {
2897				my $name = shift;
2898
2899				if($name =~ /^\s*$/ \|\| $name eq 'COMMENT' \|\| $name eq 'HISTORY') {
2900				return 1;
2901				}
2902
2903				return 0;
2904				}
2905
2906				sub delete_curr_hdu {
2907				my $fp = shift; # FITS_open has run and this is the returned file pointer
2908				my $statr = shift;
2909				return if $$statr > 0;
2910				ffdhdu($fp,0,$$statr);
2911				# Place pointer at previous (not shifted) HDU.
2912				my $nhdus = get_num_hdus($fp,$statr);
2913				my $curr = get_curr_hdu($fp,$statr);
2914				return if $$statr > 0;
2915				if($curr == 1) { return 1; } # Nowhere to go back to
2916				if($curr == $nhdus) { return $curr} # Already back
2917				move_to_hdu($fp,$curr-1,$statr);
2918				return if $$statr > 0;
2919				return $curr-1;
2920				}
2921
2922				# Create or replace HDUs for an opened file.
2923				# hdudefs has one of these structures:
2924				# (Type 1 now deprecated and considered an error)
2925				# 2: [{ hdu=>$hdudef, ?hdutype=>$type?, ?hduname=>$name?, ?hdunum=>$name?},...]
2926				# or
2927				# 3: [ $hdudef, $hdudef, $hdudef, ...]
2928				# or
2929				# 4: $hdudef
2930				# $hdudef = [{name=>name1,value=>value1}, ... 4.1
2931				# or [name1=>value1,name2=>value2,... 4.2
2932				sub create_hdus {
2933				my $fp = shift; # FITS_open has run and this is the returned file pointer
2934				my $hdudefs = shift;
2935				my $opts = shift \|\| {};
2936				my $statr = shift;
2937				my $at; # Last HDU processed
2938				my ($verbose,$replace) = @{$opts}{qw(verbose replace)};
2939				my $like = $opts->{like} \|\| $opts->{with};
2940
2941				return if $$statr > 0;
2942
2943				if(! $fp) {
2944				carp "$err/CRHDUS: No file pointer provided.\n";
2945				$$statr = 10000;
2946				return;
2947				}
2948
2949				if(! $like && ! $hdudefs) {
2950				carp "$err/CRHDUS: No HDU def or model provided.\n";
2951				$$statr = 10000;
2952				return;
2953				}
2954
2955				$hdudefs = normalize_hdudef($hdudefs) if $hdudefs;
2956
2957				my $addhdudefs;
2958				if($like) {
2959				# Make 1 or more HDU def.s from the file info ref. in $opts->{like}
2960				my $like_obj;
2961				if(! ref $like) {
2962				$like_obj = FITSIO->new($like);
2963				if(! $like_obj) {
2964				carp "$err/CRHDUS: HDU def model '$like' not available.\n";
2965				$$statr = 10000;
2966				return;
2967				}
2968				} else {
2969				$like_obj = $like;
2970				}
2971				print "\nInitializing HDU definitions from model ".$like_obj->file.".\n"
2972				if $verbose;
2973				my $likehdu = get_hdu_meta($like_obj->fp,{full=>1,hdunum=>'*'},$statr)
2974				or return;
2975				#print Dumper($likehdu),"\n";
2976				$addhdudefs = $hdudefs;
2977				$hdudefs = make_hdu_def_like($likehdu);
2978				}
2979
2980				#
2981				# Finally we're ready to actually produce (update) HDUs from the def.s
2982				#
2983
2984				for my $i (0..$#$hdudefs) {
2985				my ($hdun,$name,$type,$rtype,$vers,$hdu,$hdudef,%lookup,$currhdu);
2986
2987				$hdudef = $hdudefs->[$i];
2988
2989				# Canonicalize HDU definitions
2990
2991				# print "$i, in : ".Dumper($hdudef)."\n";
2992
2993				$hdu = make_hdudef_std($hdudef->{hdu}) or return;
2994
2995				$hdun = get_curr_hdu($fp,$statr);
2996				my $newhdu = get_num_hdus($fp,$statr)+1;
2997
2998				# Build a data structure to look up particular keywords more easily
2999				%lookup = map { ($_->{name} => $_->{value}) } @$hdu;
3000				# Provide name and type of the extension
3001				$name= $hdudef->{hduname} \|\| $lookup{EXTNAME} \|\| $lookup{HDUNAME}
3002				\|\| "";
3003				$type= $hdudef->{hdutype} \|\| $lookup{XTENSION} \|\| $lookup{HDUTYPE}
3004				\|\| 'IMAGE';
3005				$rtype=hdutypes($type); # Numerical extension type
3006				$type= hdunames($rtype); # Canonicalized extension type
3007				$vers= $hdudef->{hduver} \|\| $lookup{EXTVER} \|\| "";
3008				if($name && ! $lookup{EXTNAME}) {
3009				push @$hdu,{name=>'EXTNAME', value=>$name, type=>'C'};
3010				}
3011				if($vers && ! $lookup{EXTVER}) {
3012				push @$hdu,{name=>'EXTVER', value=>$vers, type=>'C'};
3013				}
3014				# Add the LONGSTRN keyword
3015				push @$hdu,{name=>'LONGSTRN', value=>'OGIP 1.0', type=>'C'};
3016
3017				print " Building $type extension at HDU $newhdu ($name/$vers) ...\n"
3018				if $verbose;
3019
3020				# Set up mandatory key cards
3021				# print Dumper(\%lookup)."\n";
3022				if($type eq 'IMAGE') {
3023				# Image extension
3024				# Get image size data
3025				my ($naxis,$naxes,$bpix);
3026				$naxis = $lookup{NAXIS};
3027				$naxes = $lookup{NAXES} \|\| collapse_array(\%lookup,'NAXIS',$naxis)
3028				\|\| [];
3029				$bpix = $lookup{BITPIX} \|\| -32;
3030				if(! $naxis) { $naxis = @$naxes; }
3031				ffcrim($fp,$bpix,$naxis,$naxes,$$statr);
3032				print "\t\tNAXIS=$naxis,AXES=(@$naxes),BITPIX=$bpix,STAT=$$statr\n"
3033				if $verbose;
3034				} elsif($type =~ /tbl$/i) {
3035				# ASCII or binary table extension
3036				my ($tfields,$ttype,$tform,$tunit);
3037				$tfields = $lookup{TFIELDS};
3038				$tform= collapse_array(\%lookup,"TFORM",$tfields);
3039				if(! defined $tfields) { $tfields = @$tform; }
3040				$ttype= collapse_array(\%lookup,"TTYPE",$tfields);
3041				$tunit= collapse_array(\%lookup,"TUNIT",$tfields);
3042				print "\t\tTFIELDS=$tfields\n" if $verbose;
3043				#print "$ttype->[$_],$tform->[$_]\n" for 0..$tfields-1;
3044				ffcrtb($fp,$rtype,0,$tfields,$ttype,$tform,$tunit,undef,$$statr);
3045				# If there were comments in the column definitions
3046				# then modify their default comment.
3047				for my $card (@$hdu) {
3048				next if ! defined $card->{comment};
3049				next if $card->{name} !~ /^TTYPE\d+\|TFORM\d+\|TUNIT\d+$/;
3050				#print "Updating comment for $card->{name} ...\n";
3051				update_key($fp,{name=>$card->{name},
3052				addcomment=>$card->{comment}},
3053				$statr);
3054				}
3055				# Could do the same for $tform and $tunit ...
3056				} else {
3057				confess "$err/CRHDU: Extension type $type not recognized.\n";
3058				}
3059
3060				return if $$statr>0;
3061
3062				# Key/comment/history/etc. cards
3063				for my $card (@$hdu) {
3064				# Already done with the ffcr(im\|tb) call?
3065				next if $card->{name} =~ m%^ ( BITPIX \| XTENSION \| NAXIS\d* \|
3066				NAXES \| SIMPLE \| EXTEND \| END \|
3067				TFIELDS \| TTYPE\d+ \| TFORM\d+ \|
3068				TUNIT\d+ )
3069				$ %x;
3070				# Also do not copy the annoying FITS banner ...
3071				next if $card->{name} eq "COMMENT" &&
3072				(($card->{comment}\|\|"")=~/$Banner/i \|\|
3073				($card->{value} \|\|"")=~/$Banner/i);
3074				update_key($fp,$card,$statr);
3075				#print "Updating $card->{name} $$statr ...\n";
3076				return if $$statr>0;
3077				}
3078
3079				# Add manual override cards
3080				my $addhdudef = $addhdudefs ? $addhdudefs->[$i] : undef;
3081				if($addhdudef) {
3082				$hdu = make_hdudef_std($addhdudef->{hdu}) or return;
3083				for my $card (@$hdu) {
3084				update_key($fp,$card,$statr);
3085				#print "Updating $card->{name} $$statr ...\n";
3086				return if $$statr>0;
3087				}
3088				}
3089				}
3090
3091				return 1;
3092				}
3093
3094				sub classify_hdudef {
3095				my $hdudefs = shift;
3096				my $deftype;
3097				# First identify the type of HDU def used and then translate the different
3098				# types into type 2. Then we'll be able to process the defs and
3099				# produce the HDUs.
3100				# (This is over-complicated, but doesn't take any time!)
3101				if(ref($hdudefs) !~ /array/i) { $deftype= 0; } # Oops
3102				elsif(! @$hdudefs) { $deftype= -1; } # Oops
3103				elsif(! ref $hdudefs->[0]) { $deftype= 4.2; } # [$
3104				elsif(ref($hdudefs->[0]) =~ /hash/i) { # 2/4 - [{
3105				if(exists $hdudefs->[0]{hdu}) { $deftype= 2; } # [{hdu=>
3106				elsif(exists $hdudefs->[0]{name} \|\|
3107				exists $hdudefs->[0]{comment}) { $deftype= 4.1;} # [{name=>
3108				else { $deftype= -2;} # Oops
3109				} elsif(ref($hdudefs->[0]) =~ /array/i) { # 3/4 - [[
3110				if(! @{$hdudefs->[0]}) { $deftype= -3; } # Oops
3111				elsif(! ref $hdudefs->[0][0]) { $deftype= 3.2;} # [[$
3112				elsif(ref($hdudefs->[0][0]) =~ /hash/i) { $deftype= 3.1;} # [[{
3113				elsif(ref($hdudefs->[0][0]) =~ /array/i){ $deftype= -6;} # Oops
3114				else { $deftype= -4; } # Oops
3115				} else { $deftype= -5; } # Oops
3116
3117				return $deftype;
3118				}
3119
3120				sub normalize_hdudef {
3121				my $hdudefs = shift;
3122				my $deftype; # Which type of definition is it?
3123
3124				$deftype = classify_hdudef($hdudefs);
3125
3126				if($deftype <= 1) {
3127				confess "$err/CRHDUS: Illegal HDU definition type $deftype.\n";
3128				}
3129
3130				# Step by step turn all def. types into type 2.
3131				# Translate type 4 into type 3
3132				if(int($deftype) == 4) {
3133				$hdudefs = [ $hdudefs ];
3134				}
3135				# Translate type 3 into type 2
3136				if(int($deftype) != 2) {
3137				my $i=1;
3138				$hdudefs = [ map { { hdunum=>$i++, hdu=>$_ } } @$hdudefs ];
3139				}
3140
3141				return $hdudefs;
3142				}
3143
3144				# Collapse a series of indexed keyword/value elements in a hash into an array
3145				sub collapse_array {
3146				my $lookup = shift;
3147				my $base = shift;
3148				my $n = shift;
3149				my $def = shift;
3150				my @ary;
3151
3152				# Already collapsed ?
3153				return $lookup->{$base} if ref($lookup->{$base}) =~ /array/i;
3154
3155				$n = 1000 if ! defined $n;
3156				$def="" if ! defined $def;
3157
3158				for my $i (1..$n) {
3159				last if ! defined $lookup->{"$base$i"} && $n > 999;
3160				$ary[$i-1] = defined $lookup->{"$base$i"} ?
3161				$lookup->{"$base$i"} : $def;
3162				}
3163
3164				return \@ary;
3165				}
3166
3167
3168				sub remove_key {
3169				my $fp = shift;
3170				my $name = shift;
3171				my $statr = shift;
3172				my @info;
3173				if($name =~ /\D/) { # Has a non-digit; must be a name
3174				@info = read_key($fp,$name,undef,$statr);
3175				} else { # All digits; must be a number
3176				@info = read_key($fp,undef,$name,$statr);
3177				}
3178				# 0 1 2 3 4 5 6 7
3179				# ($name,$val,$com,$type,$unit,$card,$num,$next)
3180
3181				carp("$err/RMKEY: No key '$name' found.\n"),$$statr=10000,return
3182				if ! $info[0];
3183
3184				ffdkey($fp,$info[0],$$statr);
3185
3186				return if $$statr>0;
3187
3188				return 1;
3189				}
3190
3191
3192				sub update_key {
3193				my $fp = shift;
3194				my $def = shift;
3195				my $statr = shift;
3196
3197				return if $$statr>0;
3198
3199				if(ref($def) =~ /array/i) {
3200				for (@$def) {
3201				update_key($fp,$_,$statr) or return;
3202				}
3203				return 1;
3204				}
3205
3206				#print "--- /$def->{name}/$def->{type}/$def->{value}/$def->{comment}/\n";
3207
3208				if ($def->{name} && $def->{name} eq 'COMMENT') { # comment card
3209				# Always added, not really "updated"
3210				my $com = $def->{value}\|\|$def->{comment}\|\|"";
3211				#print "Updating COMMENT '$com'.\n"; #####
3212				ffpcom($fp,$com,$$statr);
3213				} elsif ($def->{name} && $def->{name} eq 'HISTORY') { # history card
3214				# Always added, not really "updated"
3215				my $hist = $def->{value}\|\|$def->{comment}\|\|"";
3216				#print "Updating HISTORY '$hist'.\n"; #####
3217				ffphis($fp,$hist,$$statr);
3218				} elsif(defined $def->{type} && exists $def->{value}) { # key=value keyword card
3219				my $val = defined $def->{value} ? $def->{value} : "'<undef>'";
3220				#print "--- /$def->{name}/$def->{type}/$def->{com}/\n";
3221				my $type= keytypes($def->{type}) ? keytypes($def->{type})
3222				: val_to_type($val)\|\|'C';
3223				my $dtype=dkeytype($type);
3224				my $com = $def->{comment}\|\|"";
3225				my $unit= $def->{unit}\|\|"";
3226				$val = $type eq 'X' ? [c_split($def->{value})] : $val;
3227				#print "Updating '$def->{name}', type='$type', val='$val'(len=".
3228				# length($val)."), dtype=$dtype\n"; #####
3229				# The funny '$val .= "\0" x 80;' stuff:
3230				# Make sure $val has some extra storage allocated for it to try
3231				# and work-around a possible bug in CFTISIO at lin e434 in putket.c
3232				# where it may (just maybe; I'm guessing here) try to copy past
3233				# the end of the value.
3234				if($type eq 'C' && length($val) > 68) {
3235				#print "VAL='$val'\n";
3236				$val .= "\0" x 80;
3237				ffukls($fp,$def->{name},$val,$com,$$statr);
3238				} else {
3239				ffuky($fp,$dtype,$def->{name},$val,$com,$$statr);
3240				}
3241				ffpunt($fp,$def->{name},$unit,$$statr)
3242				if $unit;
3243				} elsif ($def->{name} && defined $def->{addcomment}) { # name and addcom
3244				# Modify the comment record
3245				#print "Adding to $def->{name} the comment '$def->{comment}' ...\n";
3246				ffmcom($fp,$def->{name},$def->{addcomment},$$statr);
3247				} else { # construct a raw card image from the name and comment fields
3248				# Always added, not really "updated" exactly.
3249				my $name = $def->{name} \|\| "";
3250				my $card = $name.(" " x (8-length($name))).($def->{comment}\|\|"");
3251				#print "Updating '$card' ($$statr)'.\n"; #####
3252				ffprec($fp,$card,$$statr);
3253				}
3254
3255				return if $$statr>0;
3256
3257				return 1;
3258				}
3259
3260				# Hyper-simple stuff for handling complex numbers
3261				sub c_new {
3262				my @result;
3263				while(my ($r,$i) = splice @_,0,2) {
3264				push @result, Math::Complex->make($r,$i);
3265				}
3266				return wantarray ? @result : $result[0];
3267				}
3268				sub c_split { my $c=shift; return (Re($c),Im($c)); }
3269				sub c_isit { UNIVERSAL::isa($_[0],"Math::Complex"); }
3270				# Is it one of us?
3271				sub is_fitsio { UNIVERSAL::isa($_[0],"FITSIO") }
3272
3273				sub pack_val {
3274				my $val = shift;
3275				my $type = shift;
3276				$type = keytypes($type);
3277				$val = pack(pkeytype($type),$val) unless $type eq 'X';
3278				$val = pack(pkeytype($type),c_split($val)) if $type eq 'X';
3279				return $val;
3280				}
3281
3282	1	3.0e-5	3.0e-5	my %keytypes = (
3283				c=>'C', char=>'C', string=>'C', str=>'C',
3284				d=>'F', real=>'F', r=>'F', dbl=>'F', double=>'F',
3285				f=>'F', float=>'F', flt=>'F',
3286				i=>'I', integer=>'I',int=>'I',
3287				'x'=>'X', complex=>'X',cmplx=>'X', comp=>'X',
3288				l=>'L', bool=>'L', boolean=>'L',logical=>'L',
3289				);
3290				sub keytypes {
3291				my $type = shift;
3292				return $keytypes{lc $type}\|\|"";
3293				}
3294
3295	1	0.00017	0.00017	my %coltypenames = # spent 281µs making 14 calls to Astro::FITS::CFITSIO::AUTOLOAD, avg 20µs/call
3296				(
3297				b=>'B', byte=>'B', char=>'B', 8=>'B',
3298				i=>'I', short=>'I', s=>'I', 16=>'I',
3299				ushort=>'I', us=>'I', # white lie
3300				j=>'J', integer=>'J', int=>'J', long=>'J', 32=>'J',
3301				ulong=>'K', ul=>'K', # white lie
3302				k=>'K', longlong=>'K', 64=>'K',
3303				a=>'A', string=>'A', str=>'A',
3304				e=>'E', float=>'E', flt=>'E', f=>'E', -32=>'E',
3305				d=>'D', double=>'D', dbl=>'D', real=>'D', r=>'D',
3306				-64=>'D',
3307				c=>'C', complex=>'C', cmplx=>'C', comp=>'C',
3308				m=>'M', dblcomplex=>'M',dblcmplx=>'M',dcmplx=>'M',
3309				dcomp=>'M',
3310				l=>'L', logical=>'L', boolean=>'L', bool=>'L',
3311				'x'=>'X', bit=>'X',
3312				p=>'P',
3313				&TSTRING=>'A', &TLOGICAL=>'L', &TBIT=>'X',
3314				&TINT=>'J', &TLONG=>'J', &TLONGLONG=>'K', &TSHORT=>'I',
3315				&TBYTE=>'B', &TUSHORT=>'I', &TULONG=>'J',
3316				&TDOUBLE=>'D', &TFLOAT=>'E',
3317				&TDBLCOMPLEX=>'M', &TCOMPLEX=>'C',
3318				PDL_F=>'E', PDL_D=>'D', PDL_S=>'I', PDL_US=>'I',
3319				PDL_L=>'J', PDL_LL=>'K', PDL_B=>'B',
3320				);
3321				# Convert a synonym into a canonical column name. Note the conflict of the 'X'
3322				# and 'C' types with key value types. This is annoying.
3323				sub coltypename {
3324				my $type = shift;
3325				return $coltypenames{lc $type\|\|""};
3326				}
3327
3328	1	7.3e-5	7.3e-5	my %dcoltypenames = ( # spent 52µs making 12 calls to Astro::FITS::CFITSIO::__ANON__[/wise/base/static/lib/perl5/site_perl/5.10.0/x86_64-linux-thread-multi/Astro/FITS/CFITSIO.pm:798], avg 4µs/call
3329				&TSTRING=>'A', &TLOGICAL=>'L',
3330				&TBIT=>'X',
3331				# TLONG and TINT are actually different iszes (8
3332				# and 4 bytes) on some machines, but we want to
3333				# make sure both get asssociated with 'J'-type
3334				# columns because FITS has no real distinction
3335				# between int and long, and the 64 bit type is
3336				# 'k' and isn't really standard.
3337				&TLONG=>'J', &TINT=>'J',
3338				&TLONGLONG=>'K',
3339				&TSHORT=>'I', &TBYTE=>'B',
3340				&TDOUBLE=>'D', &TFLOAT=>'E',
3341				&TDBLCOMPLEX=>'M', &TCOMPLEX=>'C'
3342				);
3343	1	3.0e-5	3.0e-5	my %dcoltypes = (reverse(%dcoltypenames), # spent 13µs making 3 calls to Astro::FITS::CFITSIO::__ANON__[/wise/base/static/lib/perl5/site_perl/5.10.0/x86_64-linux-thread-multi/Astro/FITS/CFITSIO.pm:798], avg 4µs/call
3344				# Overrides
3345				'F'=>&TFLOAT, 'G'=>&TFLOAT,
3346				# We need this override below to make sure a 'j'
3347				# column comes out as 4 bytes. CFITSIO is (or was)
3348				# misconfigured to think it should be 64 bits on some
3349				# machines.
3350				'J'=>&TINT
3351				);
3352
3353
3354	1	4.0e-6	4.0e-6	my %colsizes = ('B'=>1, 'I'=>2, 'J'=>4, 'K'=>8, 'E'=>4, 'F'=>4, 'G'=>4, 'D'=>8,
3355				'L'=>1, 'X'=>1, 'C'=>8, 'M'=>16,'A'=>1);
3356
3357				# CFITSIO column data type macro value to canonical type char.
3358				sub dcoltypename {
3359				my $type = shift;
3360				return $dcoltypenames{abs($type\|\|0)};
3361				}
3362				# The reverse
3363				sub dcoltype {
3364				my $name = shift;
3365				return $dcoltypes{uc coltypename($name)\|\|""};
3366				}
3367
3368				# Pack formats for $repeat number of col value types.
3369				sub pcoltype {
3370				my $type = shift;
3371				my $repeat = shift;
3372				my $width = shift \|\| 1;
3373				my ($fmt,$ptype);
3374				my %ptypes = (
3375				a=>'a', j=>'l', i=>'s', e=>'f', d=>'d',
3376				c=>'f', m=>'d', b=>'c', x=>'c', l=>'c'
3377				);
3378				if(! defined $repeat) { $repeat = 1; }
3379				$type = lc coltypename($type);
3380				$ptype = $ptypes{$type};
3381				if($repeat) {
3382				if($type ne 'a') { # Non-strings
3383				if($type !~ /^[cm]$/o) { $fmt = $ptype.$repeat; } # Scalars
3384				else { $fmt = $ptype.(2*$repeat); } # Complex
3385				} else { # Strings
3386				if($width == 1) { $fmt = $ptype.$repeat; }
3387				else { $fmt = ($ptype.$width) x $repeat; }
3388				}
3389				} else {
3390				$fmt = $ptype;
3391				}
3392				return $fmt;
3393				}
3394
3395				# Pack formats for $repeat number of col value types.
3396				sub colsize {
3397				my $iname = shift; # Col type name
3398				my $repeat = shift; # No. elem.s per row
3399				my $width = shift; # Length of single element
3400				my ($name,$dtype);
3401				$repeat = defined $repeat? $repeat : 1; # Apply default
3402				if(! defined $width) {
3403				$name = coltypename($iname); # Alias-to-canonical col. type conversion
3404				# Interpret a string as a single char, then apply its width later
3405				$dtype = dcoltype($name eq 'A' \|\| $name eq 'X' # CFITSIO col. type no.
3406				? 'B'
3407				: $name);
3408				$width = CFITSIO::sizeof_datatype($dtype);
3409				}
3410				#print "----- iname=$iname, name=$name, dtype=$dtype, width=$width, ". ####
3411				# "repeat=$repeat\n"; ######
3412				return $repeat*$width;
3413				}
3414
3415				# What to display for p/o of a column type
3416				sub coldispname {
3417				my $type = shift;
3418				my %types = (
3419				b=>'byte',i=>'short',j=>'long', a=>'str',
3420				e=>'float', d=>'dbl',
3421				c=>'comp',m=>'dcomp',l=>'bool', x=>'bit', p=>'pack'
3422				);
3423				return $types{lc coltypename($type)\|\|""};
3424				}
3425
3426				# What to display for p/o of a key type
3427				sub keydispname {
3428				my $type = shift;
3429				my %types = ( c=>'char', i=>'int', f=>'real', x=>'comp', l=>'bool' );
3430				return $types{lc keytypes($type)\|\|""};
3431				}
3432
3433				# C types for key value types.
3434				sub ckeytype {
3435				my $type = shift;
3436				my %ctypes = (
3437				c =>'char', l=>'int', i=>'int', f=>'double',
3438				'x' =>'double',
3439				);
3440				return $ctypes{lc keytypes($type)\|\|""};
3441				}
3442
3443				# CFITSIO datatype macro values for key value types.
3444				sub dkeytype {
3445				my $type = shift;
3446				my %dtypes = (
3447				c =>TSTRING, l=>TLOGICAL, i=>TINT, f=>TDOUBLE,
3448				'x'=>TDBLCOMPLEX,
3449				);
3450				return $dtypes{lc keytypes($type)\|\|""};
3451				}
3452
3453				# Pack formats for key value types.
3454				sub pkeytype {
3455				my $type = shift;
3456				my %ptypes = (
3457				c =>"a*Z", l=>"i", i=>"i", f=>"d",
3458				'x' =>"dd",
3459				);
3460				return $ptypes{lc keytypes($type)\|\|""};
3461				}
3462
3463				# Aliases for HDU types
3464	1	0.00013	0.00013	my %hdutypes = ( # spent 99µs making 25 calls to Astro::FITS::CFITSIO::__ANON__[/wise/base/static/lib/perl5/site_perl/5.10.0/x86_64-linux-thread-multi/Astro/FITS/CFITSIO.pm:798], avg 4µs/call # spent 85µs making 4 calls to Astro::FITS::CFITSIO::AUTOLOAD, avg 21µs/call
3465				IMAGE_HDU=> &IMAGE_HDU,
3466				IMAGEHDU => &IMAGE_HDU,
3467				IMAGE => &IMAGE_HDU,
3468				IMG => &IMAGE_HDU,
3469				I => &IMAGE_HDU,
3470				IMG_HDU => &IMAGE_HDU,
3471				IMGHDU => &IMAGE_HDU,
3472				PRIMARY => &IMAGE_HDU,
3473				ASCII_TBL=> &ASCII_TBL,
3474				ASCIITBL => &ASCII_TBL,
3475				ASCII => &ASCII_TBL,
3476				ASC => &ASCII_TBL,
3477				ASCTABLE => &ASCII_TBL,
3478				ASCTBL => &ASCII_TBL,
3479				A => &ASCII_TBL,
3480				BINARY_TBL=>&BINARY_TBL,
3481				BINARYTBL=> &BINARY_TBL,
3482				BIN => &BINARY_TBL,
3483				BINTBL => &BINARY_TBL,
3484				BINTABLE => &BINARY_TBL,
3485				BINARY => &BINARY_TBL,
3486				TABLE => &BINARY_TBL,
3487				TBL => &BINARY_TBL,
3488				B => &BINARY_TBL,
3489				T => &BINARY_TBL,
3490				ANY_HDU => &ANY_HDU,
3491				ANY => &ANY_HDU,
3492				ALL => &ANY_HDU,
3493				UNKNOWN => &ANY_HDU
3494				);
3495				# The reverse
3496	1	2.7e-5	2.7e-5	my %hdunames = ( # spent 19µs making 4 calls to Astro::FITS::CFITSIO::__ANON__[/wise/base/static/lib/perl5/site_perl/5.10.0/x86_64-linux-thread-multi/Astro/FITS/CFITSIO.pm:798], avg 5µs/call
3497				&IMAGE_HDU => 'IMAGE',
3498				&ASCII_TBL => 'ASCII_TBL',
3499				&BINARY_TBL=> 'BINARY_TBL',
3500				&ANY_HDU => 'UNKNOWN'
3501				);
3502
3503				sub hdutypes {
3504				return defined $hdutypes{uc $_[0]} ? $hdutypes{uc $_[0]} : ANY_HDU;
3505				}
3506				sub hdunames {
3507				return $hdunames{$_[0]} \|\| 'UNKNOWN';
3508				}
3509
3510				# Close the file
3511				sub close_file {
3512				my $fp = shift;
3513				return if ! defined $fp;
3514
3515				my $statr = shift;
3516
3517				return if $$statr>0;
3518
3519				ffclos($fp,$$statr);
3520				return if $$statr>0;
3521
3522				return 1;
3523				}
3524
3525				# Get the mandatory keywords for the current HDU
3526				sub get_std_keys {
3527				my $fp = shift;
3528				my $statr = shift;
3529				my $type = get_hdu_type($fp,$statr);
3530				my ($simp,$bpix,$naxis,$naxes,$pcnt,$gcnt,$xtnd,$bscl,$bzero,$blnk);
3531				my ($nrows,$tflds,$ttp,$tfrm,$tun,$xnm,$nfnd,$tscal,$tzero,$tnull,$com);
3532				my ($rowlen,$tbcol,$tmp);
3533				my (%std);
3534
3535				return if $$statr>0;
3536
3537				if($type eq "IMAGE") {
3538				ffghpr($fp,$simp,$bpix,$naxis,$naxes,$pcnt,$gcnt,$xtnd,$$statr);
3539				return if $$statr>0;
3540				ffgkyd($fp,"BZERO",$bzero,$com,$tmp=0); # Don't care if not found
3541				ffgkyd($fp,"BSCALE",$bscl,$com,$tmp=0); # Don't care
3542				ffgkyl($fp,"BLANK",$blnk,$com,$tmp=0); # Don't care
3543				if($blnk == NULL_UNDEFINED) { $blnk = "NULL_UNDEFINED"; }
3544				%std = (SIMPLE=>$simp, BITPIX=>$bpix, NAXIS=>$naxis, NAXES=>$naxes,
3545				PCOUNT=>$pcnt, GCOUNT=>$gcnt, EXTEND=>$xtnd, BZERO=>$bzero,
3546				BSCALE=>$bscl, BLANK=>$blnk);
3547				} elsif($type eq "BINARY_TBL") {
3548				ffghbn($fp,$nrows,$tflds,$ttp,$tfrm,$tun,$xnm,$pcnt,$$statr);
3549				return if $$statr>0;
3550				ffgknd($fp,"TSCAL",1,$tflds,$tscal,$nfnd,$tmp=0); # Don't care
3551				ffgknd($fp,"TZERO",1,$tflds,$tzero,$nfnd,$tmp=0); # Don't care
3552				ffgknl($fp,"TNULL",1,$tflds,$tnull,$nfnd,$tmp=0); # Don't care
3553				%std = (NAXIS2=>$nrows, TFIELDS=>$tflds, TTYPE=>$ttp, TFORM=>$tfrm,
3554				TUNIT=>$tun, EXTNAME=>$xnm, PCOUNT=>$pcnt,
3555				TSCAL=>$tscal,TZERO=>$tzero,TNULL=>$tnull);
3556				} elsif($type eq "ASCII_TBL") {
3557				ffghtb($fp,$rowlen,$nrows,$tflds,$ttp,$tbcol,$tfrm,$tun,$xnm,$$statr);
3558				return if $$statr>0;
3559				ffgknd($fp,"TSCAL",1,$tflds,$tscal,$nfnd,$tmp=0); # Don't care
3560				ffgknd($fp,"TZERO",1,$tflds,$tzero,$nfnd,$tmp=0); # Don't care
3561				ffgknl($fp,"TNULL",1,$tflds,$tnull,$nfnd,$tmp=0); # Don't care
3562				%std = (NAXIS1=>$rowlen, NAXIS2=>$nrows, TFIELDS=>$tflds,
3563				TTYPE=>$ttp, TFORM=>$tfrm, TBCOL=>$tbcol,
3564				TUNIT=>$tun, EXTNAME=>$xnm,
3565				TSCAL=>$tscal,TZERO=>$tzero,TNULL=>$tnull);
3566				} else {
3567				carp "$warn/GETSTD: Don't recognize extension type '$type'";
3568				$$statr=10000;
3569				return;
3570				}
3571
3572				return \%std;
3573				}
3574
3575				sub get_num_keys {
3576				my $fp = shift;
3577				my $statr = shift;
3578				my ($nkeys,$curloc);
3579				ffghps($fp,$nkeys=0,$curloc,$$statr);
3580				return if $$statr>0;
3581				return wantarray ? ($nkeys,$curloc) : $nkeys;
3582				}
3583
3584				#
3585				# Get all the keywords for the current HDU
3586				sub get_all_keys {
3587				my $fp = shift;
3588				my $opts = shift;
3589				my $statr= shift;
3590				my ($merge) = @{$opts}{qw(merge)};
3591				my ($ref,@hdu);
3592				my ($card,$name,$val,$com,$type,$unit,$num,$next);
3593				my ($nkeys,$tmp,$len);
3594
3595				return if $$statr>0;
3596
3597				# print "Get_all. status=$$statr\n"; #####
3598				$nkeys = get_num_keys($fp,$statr);
3599				return if $$statr>0;
3600				# print "get_all_keys: nkeys=$nkeys, status=$$statr\n"; #####
3601				return \@hdu if $nkeys <= 0 ;
3602				$next = 0;
3603				for my $i (1..$nkeys) {
3604				# print "$i/$next/$nkeys ...\n"; #####
3605				next if $i < $next;
3606				($name,$val,$com,$type,$unit,$card,$num,$next) =
3607				read_key($fp,undef,$i,$statr);
3608				next if $name eq 'CONTINUE'; # Don't need to read CONTINUE cards
3609				#print "$i/$nkeys: name=/$name/,val=/$val/,com=/$com/,".
3610				# "type=/$type/,unit=/$unit/, next=/$next/\n";
3611				$ref = {value=>$val,unit=>$unit,comment=>$com,
3612				name=>$name,type=>$type,card=>$card,index=>$i};
3613				push @hdu, $ref;
3614				}
3615
3616				if($merge) {
3617				# Look for sequentially numbered cards (starting at 1) and merge them
3618				# into one array, deleting the others
3619				my (@keep,$name,%head);
3620				my %spcl = map {($_=>1)}
3621				qw(NAXIS TTYPE TUNIT TFORM TNULL TDIM TSCAL TZERO);
3622				for (@hdu) {
3623				# Does the key name end with a non-digit followed by a digit?
3624				if(my ($base,$num) = $_->{name} =~ /^\s(.?\D)(\d+)\s*$/) {
3625				# print "GOT $_->{name}; $base - $num\n";
3626				if(defined $_->{value} && # Only merge non-comment cards
3627				! $head{$base}) { # Have we seen $base before?
3628				my $next = $num;
3629				++$next; # Magic autoincrement preserves leading zeros
3630				# Is it special, or is there another card in sequence?
3631				if($spcl{$base} \|\| grep($_->{name} eq $base.$next,@hdu)) {
3632				$head{$base} = $_; # Keep a reference for later use
3633				$_->{value} = [ ('')x($num-1),$_->{value} ]; # New val
3634				# Special convention to disambiguate NAXIS from
3635				# NAXIS1, NAXIS2 etc. Bad FITS naming convention.
3636				$_->{name} = $base eq 'NAXIS' ? 'NAXES' : $base;
3637				}
3638				} elsif($head{$1}) { # We found another one
3639				$head{$1}{value}[$2-1] = $_->{value} ;
3640				next; # Remove old def from list
3641				}
3642				}
3643				push @keep,$_;
3644				}
3645				@hdu = @keep;
3646				}
3647
3648				return \@hdu;
3649				}
3650
3651				# Read a single 'key=val/comment' card by name or number. Long names and long
3652				# strings should be handled OK.
3653				sub read_key {
3654				my $fp = shift;
3655				my $name = shift;
3656				my $num = shift;
3657				my $statr = shift;
3658				my ($card,$nkeys,$val,$type,$i,$len,$com,$unit,$next);
3659
3660				return if $$statr > 0;
3661
3662				if(defined $name) {
3663				ffgcrd($fp,$name,$card,$$statr);
3664				if($$statr == KEY_NO_EXIST) { # Treat key absence as a non-error
3665				ffcmsg();
3666				$$statr = 0;
3667				return;
3668				}
3669				($nkeys,$num) = get_num_keys($fp,$statr);
3670				} else {
3671				ffgrec($fp,$num,$card,$$statr);
3672				ffgknm($card,$name,$len,$$statr);
3673				$nkeys = get_num_keys($fp,$statr);
3674				}
3675
3676				ffpsvc($card,$val,$com,$$statr);
3677
3678				$type = get_val_type($val,$statr) if $val ne "";
3679				$type \|\|= "";
3680
3681				return if $$statr>0;
3682
3683				# Put this here instead of below because the look-up-by-name
3684				# messes up our position if there are multiple cards with the
3685				# same name.
3686				($nkeys,$next) = get_num_keys($fp,$statr);
3687
3688				if($type) {
3689				if($type eq 'C') { # Reread the card as a possible long string
3690				ffgkls($fp,$name,$val,$com,$$statr);
3691				$val =~ s/^\s[''](.?)['']?\s*$/$1/;
3692				} elsif ($type eq 'X') { # Parse as a complex type
3693				ffgkym($fp,$name,$val,$com,$$statr); # Val is a 2 elem. array ref.
3694				$val = c_new($val->[0],$val->[1]);
3695				} elsif ($type eq 'L') { # Convert character boolean val.s to ints
3696				$val = {'T'=>1, 'F'=>0}->{uc $val};
3697				}
3698				}
3699
3700				return if $$statr>0;
3701
3702				if(defined $val && $com) { # Get a unit
3703				($unit) = $com =~ /^\s\[\s(\S.?)\s\]/;
3704				$unit \|\|= "";
3705				}
3706
3707				return wantarray ? ($name,$val,$com,$type,$unit,$card,$num,$next) : $val;
3708				}
3709
3710				# Get type from a raw value string from the header
3711				sub get_val_type {
3712				my $val = shift;
3713				my $statr = shift;
3714				my $type; # Preallocated space;
3715				return if $$statr>0;
3716				ffdtyp($val,$type,$$statr);
3717				return if $$statr>0;
3718				return substr($type,0,1);
3719				}
3720
3721				# Get the type from the data as stored in the the perl hdu hash
3722				sub val_to_type {
3723				my $val = shift;
3724				my $stat;
3725				my $fpre = FPRE; # RE to match a f.p. number.
3726
3727				return "" if ! defined $val;
3728
3729				if(c_isit($val)) { return 'X'; } # Complex number?
3730				elsif(ref($val) =~ /hash/i) { return val_to_type($val->{value}); }
3731				# List of many values; they are all assumed to be of the same type
3732				elsif(ref($val) =~ /array/i) { return val_to_type($val->[0]); }
3733				elsif(ref($val)) { return ""; }
3734
3735				# Not a reference
3736				# (We can't use ffdtyp because we store strings without the quotes)
3737				if($val=~/^[-+]?\d+$/) { return 'I'; }
3738				elsif($val=~/^$fpre$/) { return 'F'; }
3739				elsif($val=~/^[tf]$/i) { return 'L'; }
3740				else { return 'C'; }
3741				}
3742
3743				# Get a value type assuming a comment may be attached
3744				sub val_to_typecom {
3745				my $val = shift;
3746				my $com;
3747				my ($before,$after);
3748				if($val =~ s%^\s([^']\|'.')\s+/\s+(.)%$1%) {
3749				$com = $2;
3750				}
3751				my $type = val_to_type($val);
3752				return wantarray ? ($type,$val,$com) : $type;
3753				}
3754
3755				sub dump_hdu {
3756				my $fp = shift;
3757				my $hdunum = shift;
3758				my $opts = shift \|\| {};
3759				my $statr = shift;
3760				my ($val,$com,$hasval,$str,$type,$line,$spcs,$ptype,
3761				$nkeys,$name,$num,$vers,$hdu,$lines,@vals,@names);
3762
3763				my $TO = exists $opts->{dumpto} ? $opts->{dumpto} : \*STDOUT;
3764				my $comcol = exists $opts->{comcol} ? $opts->{comcol} : 36;
3765				my $prefix = $opts->{prefix}; # Prefix cards with file name
3766				my $keyre = $opts->{keyre};
3767				$keyre = [$keyre] if $keyre && ! ref $keyre;
3768				my $csv = $opts->{csv};
3769				my $ipac = $opts->{ipac};
3770				my $cols = $opts->{datacols} \|\| {};
3771				my $rownum= $opts->{rownum} \|\| 0;
3772				my $sep = $opts->{sep} \|\| ',';
3773				my $nohdr = $opts->{nohdr};
3774
3775				my $metas = get_hdu_meta($fp,{full=>1,hdunum=>$hdunum,%$opts},$statr)
3776				or return;
3777
3778				# Is $meta an an array ref?
3779				if(ref($metas) !~ /array/i) { $metas = [ $metas ]; }
3780
3781				if($ipac && $opts->{file}) {
3782				$cols->{_file}[$rownum] = $opts->{file};
3783				}
3784
3785				for my $meta (@$metas) { # Step through each selected HDU
3786
3787				if(! $meta->{-hdu}) {
3788				confess "$err/dumphdu: Bad meta received from get_hdu_meta.\n";
3789				}
3790
3791				$hdu = $meta->{-hdu};
3792				$name = $meta->{-hduname}\|\|'';
3793				$type = $meta->{-hdutype}\|\|'';
3794				$num = $meta->{-hdunum} \|\|'';
3795				$vers = $meta->{-hduver}\|\|'';
3796				$nkeys= $meta->{-nkeys}\|\|'';
3797				if($num && ! $nohdr && ! $csv && ! $ipac) {
3798				print "\nHDU #$num; type='$type', name='$name', ".
3799				"version='$vers', nkeys=$nkeys\n".("-" x 79)."\n";
3800				#print "Search for keys matching /".join("/,/",@$keyre)."/\n"
3801				# if $keyre;
3802				}
3803
3804				CARD: for my $card (@$hdu) {
3805
3806				if($card->{name} && $keyre) {
3807				# Search for matching keys
3808				LOOK: {
3809				for (@$keyre) {
3810				last LOOK if $card->{name} =~ /$_/i;
3811				}
3812				next CARD; # Failed to find a match
3813				} # Found match
3814				} elsif ($keyre) { # Need a card name if searching by name
3815				next CARD;
3816				}
3817				$ptype = $type = $card->{type}\|\|"";
3818				# A type indicates a true value is present, not just a comment
3819				$hasval = $type;
3820				$str = $type eq 'C' ? "'" : ""; # Add to strings
3821				$val = $hasval ? $card->{value} : $card->{comment}\|\|"";
3822				$com = $hasval && defined $card->{comment} &&
3823				$card->{comment} ne "" ? " / ".$card->{comment}
3824				: "";
3825				if(c_isit($val)) { $val = "(".join(",",c_split($val)).")"; }
3826				elsif(ref($val) =~ /array/i) {
3827				# This is an "array" card. Elide its values.
3828				# my @ok = grep(defined $val->[$_]&&$val->[$_]ne"",0..$#$val);
3829				# if(@ok == 1) { # Reconstruct as a single value
3830				# $card->{name} .= $ok[0]+1;
3831				# $val = defined $val->[$ok[0]] ? $val->[$ok[0]] : "";
3832				# $val = $str.$val.$str;
3833				# } else {
3834				$val = "[".$str.
3835				join("$str,$str",map { defined $_ ? $_ : "" } @$val)
3836				.$str."]";
3837				# }
3838				} else {
3839				$val = $str.$val.$str;
3840				}
3841				if(! $csv && ! $ipac) {
3842				$ptype = "" if ! $opts->{types};
3843				$line = sprintf("%s%-8.8s%s%s%s",
3844				$prefix\|\|"",
3845				$card->{name},
3846				($ptype?($type?" ($type) ":" "):""),
3847				($hasval ? "= " : " "),
3848				$val);
3849				if($comcol && $comcol>0) {
3850				$spcs = $comcol - length($line) -
3851				(length($com)>(80-$comcol)
3852				? length($com)-(80-$comcol)
3853				: 0);
3854				$com = (" " x $spcs).$com;
3855				} else {
3856				$com = "";
3857				}
3858				print $TO "$line$com\n" if $TO;
3859				$lines .= "$line$com\n" if ! $TO;
3860				} else {
3861				if($csv) {
3862				push @names,$card->{name};
3863				push @vals,$val;
3864				}
3865				if($ipac) {
3866				$val =~ s/^\s'(.)'\s*$/$1/;
3867				$cols->{lc $card->{name}}[$rownum] = $val;
3868				}
3869				}
3870				}
3871				}
3872
3873				if(@vals) {
3874				if($nohdr) {
3875				$lines = $prefix.join($sep,@vals)."\n";
3876				} else {
3877				my %vals;
3878				@vals{@names} = @vals;
3879				$lines = $prefix.join($sep,map {"$_=>$vals{$_}"} @names)."\n";
3880				}
3881				print $TO $lines if $TO;
3882				}
3883
3884				return $TO ? 1 : $lines;
3885				}
3886
3887				sub dump_cols {
3888				my $data = shift;
3889				my $iostate = shift;
3890				my $colix = shift;
3891				my $opts = shift;
3892				my @sortcols;
3893				my @cols = @{ (grep( ref $_,@{$opts->{qw/col cols column columns/}}))[0] \|\|
3894				[(grep(!ref $_,@{$opts->{qw/col cols column columns/}}))[0]]\|\|
3895				[]
3896				};
3897
3898				@sortcols = sort {$colix->{$a}<=>$colix->{$b}} keys %$data;
3899				for my $col (@sortcols) {
3900				my $data1 = $data->{$col};
3901				my $ioinf1 = $iostate->{cols}[$colix->{$col}];
3902				my $nrows = @{$data1};
3903				next if ! $data1 \|\|
3904				(@cols && ! grep($col eq $_,@{$opts->{cols}}));
3905				print "\nFor column '$col':\n";
3906				if($opts->{extra}) {
3907				print("[col#=$colix->{$col}, coltype=$ioinf1->{coltype}, ",
3908				"hdutype=$ioinf1->{hdutype}, ",
3909				"ncols/rows=$ioinf1->{maxcols}/$ioinf1->{maxrows}\n",
3910				" rowsize=$ioinf1->{rowsize}, nelems=$ioinf1->{nelems}, ",
3911				"unpk1=$ioinf1->{pack1row}, len(data)=",
3912				(ref $data1 ? scalar(@{$data1}):1),", ",
3913				"row=$ioinf1->{row}, nrows=$nrows]\n");
3914				}
3915				for my $j (0..$nrows-1) {
3916				print "row ",$ioinf1->{toprow}+$j,": ".
3917				elemstr($data1->[$j],"/")."\n";
3918				}
3919				}
3920
3921				return 1;
3922				}
3923
3924				sub elemstr {
3925				my $elem = shift;
3926				my $sep = shift \|\| "";
3927				return ref($elem) ? c_isit($elem)
3928				? '('.join(",",c_split($elem)).')'
3929				: $sep.join(",",map { elemstr($_) } @$elem)
3930				: $elem;
3931				}
3932
3933				# Call from a sub with standard arg handling. Object instance and opts (if any)
3934				# are always moved to the front of the call stack
3935				# E.g.
3936				# ($this,$opts,@_) = get_std_args(@_);
3937				# Allowed argument patterns:
3938				# foo($this,$arg1,$arg2,...,$argN,$opts);
3939				# foo($this,$arg1,$arg2,...,$argN);
3940				# foo($this,$opts);
3941				# foo($this);
3942				# foo();
3943				# where
3944				# $this must be blessed into a class deriving from FITSIO for type II calls
3945				# $opts must be a hash reference
3946				# $argN must NOT be a hash ref unless $opts is also defined
3947				sub get_std_args {
3948				my ($this,$opts);
3949
3950				# Return both the object ref and options, shifting/popping both off @_,
3951				# IF wantarray indicates both are wanted.
3952				# In a scalar context, only pop off the options (if any) and return them.
3953				$this = @_>0 && is_fitsio($_[0]) ? shift @_ : undef;
3954				$opts = @_>0 && ref($_[-1])=~/HASH/ ? pop @_ : {};
3955
3956				# Make a copy so we don't overwrite the passed options.
3957				# (This should probably be a deep copy.)
3958				$opts = { %$opts };
3959
3960				return wantarray ? ($this,$opts,@_) : $opts;
3961				}
3962
3963				# Check subroutine argument signature.
3964				# Trivial so far; just check for min/max allowed arg.s and for a correct
3965				# object.
3966				# Arg counts specified with forms like "$$$;$$" where the count must be between
3967				# 3 and 5 inclusive in this case.
3968				# A false $sig ("", 0 or undef) means skip arg count checking.
3969				# ";" means no args are expected.
3970				# Most methods signatures will look like ";$" or ";$$"
3971				# where the last "$" refers to the omni-present but optional options hash ref.
3972				# For the future (maybe):
3973				# Allow syntax like "arg1,arg2;arg2,arg4" to provide argument names.
3974				# Or something like "$arg1,%arg1;@arg3,%arg4" to specifiy types too
3975				# (all must be scalars, so '%arg' would imply a hash ref).
3976				# How 'bout "%@$arg1..." to allow multiple possible types for an arg.
3977				# If we get too fancy, speed will suffer too much, I think.
3978				sub check_sig {
3979				my $sig = shift;
3980				my $args= shift;
3981				# Check for a FITSIO object
3982				(warn("$err: No object given to '".from()."'\n"),return)
3983				if ! is_fitsio($args->[0]);
3984				return 1 if ! $sig;
3985				my $nargs = @$args - 1; # The object instance is always assumed
3986				# Check for legal arg count
3987				my ($needed,$optional) = split /\s;\s/,$sig;
3988				(warn("$err: Signature '$sig' not matched from '".
3989				from()."'; nargs=$nargs\n"),
3990				return)
3991				if $nargs < length($needed) \|\|
3992				$nargs > length($needed)+length($optional\|\|"");
3993				# All appears to be well.
3994				return 1;
3995				}
3996				# Return the name of the interesting calling subroutine; i.e. not a sub which
3997				# is probably doing error checking of some sort, but the sub that called it.
3998				sub from {
3999				my $fr = shift;
4000				my (@stack,$i,@frame);
4001				push @stack,[@frame] while @frame=caller(++$i);
4002				if(! $fr) {
4003				# Search for first frame past uninteresting routines
4004				$fr = 1;
4005				++$fr while $stack[$fr] &&
4006				grep( $stack[$fr][3] eq $_,
4007				qw(check_sig handle_err get_std_args from) );
4008				}
4009				return $stack[$fr][3]\|\|"<No caller?>";
4010				}
4011
4012				# Handle errors, mostly those discovered by cfitsio. The first arg can
4013				# either be a status (used by low-level subs) or an object containing the
4014				# status and other info as onstance data.
4015				# $msg is the message to prepend to specific error info extracted from
4016				# instance data and/or the cfitsio error stack.
4017				sub handle_err {
4018				my $stat = shift \|\| 0; # Status or object
4019				my $msg = shift \|\| "";
4020				my $opts = shift \|\| {};
4021				my ($verbose,$dieonerr,$die,$file,$this);
4022
4023				if(is_fitsio($stat)) { # stat is really an object
4024				$this = $stat;
4025				$stat = status($this);
4026				$dieonerr = $this->{dieonerr};
4027				}
4028
4029				$verbose \|\|= $opts->{verbose};
4030				$dieonerr \|\|= $opts->{dieonerr};
4031				$die \|\|= $opts->{die};
4032				$file = $opts->{file} \|\| ($this ? file($this) : undef);
4033				$file = defined $file ? " (file=$file)" : "";
4034
4035				return 1 unless $stat && $stat > -10000;
4036
4037				if(substr($msg,-1) ne "\n") {
4038				if($stat <= -10000) {
4039				# Internal FITSIO warning; do nothing for now
4040				} elsif($stat < 10000) { # cfitsio library error; get internal message
4041				chomp(my $errtxt = err_text($stat));
4042				$msg .= "$file (status=$stat); $errtxt";
4043				$msg .= ". syserr='$!'" if $!;
4044				} else { # internal FITSIO extension module error
4045				$msg .= "$file; internal status=$stat";
4046				$msg .= ". syserr='$!'" if $!;
4047				}
4048				}
4049				# Print the message
4050				carp $msg;
4051				# Print full error stack
4052				ffrprt(\*STDERR,$stat) if $stat<10000; # This seems to dump core ???
4053				# Print a stack trace
4054				cluck "\n";
4055				# Toiminate?
4056				croak "$err: Terminating" if $die \|\| ($dieonerr && $stat>0);
4057				return $stat > 0 ? undef : $stat;
4058				}
4059
4060				sub err_text {
4061				my $stat = shift \|\| 0;
4062				my $errmsg;
4063				# This line allows us to pass either encoded ints or perl ints
4064				if($stat !~ /^\d+$/) { $stat = unpack('i',$stat); }
4065				ffgerr($stat,$errmsg);
4066				return $errmsg;
4067				}
4068
4069				sub err_stack {
4070				my $errmsg;
4071				ffgmsg($errmsg);
4072				return $errmsg;
4073				}
4074
4075				# WCS routines
4076
4077				sub wcs_get_im_keys {
4078				my $fp = shift;
4079				my $statr = shift;
4080				my ($xref,$yref,$xpix,$ypix,$xdel,$ydel,$rot,$proj);
4081				return if $$statr>0;
4082				ffgics($fp,$xref,$yref,$xpix,$ypix,$xdel,$ydel,$rot,$proj,$$statr);
4083				return if $$statr>0;
4084				return ($xref,$yref,$xpix,$ypix,$xdel,$ydel,$rot,$proj);
4085				}
4086
4087				sub wcs_cel2pix {
4088				my ($ra,$dec) = (shift,shift);
4089				my ($xform) = shift;
4090				my $statr = shift;
4091				my ($x,$y);
4092				return if $$statr>0;
4093				ffxypx($ra,$dec,@$xform,$x,$y,$$statr);
4094				return if $$statr>0;
4095				return ($x,$y);
4096				}
4097
4098				sub wcs_pix2cel {
4099				my ($x,$y) = (shift,shift);
4100				my ($xform) = shift;
4101				my $statr = shift;
4102				my ($ra,$dec);
4103				return if $$statr>0;
4104				ffwldp($x,$y,@$xform,$ra,$dec,$$statr);
4105				return if $$statr>0;
4106				return ($ra,$dec);
4107				}
4108
4109	1	6.9e-5	6.9e-5	1;