Astro-FITS-Header-3.08000755004077000012 014014777770 14051 5ustar00gbellstaff000000000000Astro-FITS-Header-3.08/Build.PL000444004077000012 325014014777770 15502 0ustar00gbellstaff000000000000 use strict; use warnings; use Module::Build; # Set it up. my $build = Module::Build->new ( module_name => 'Astro::FITS::Header', license => 'gpl3', dist_abstract => 'Object-oriented interface to FITS HDUs', dist_author => [ 'Alasdair Allan ', 'Tim Jenness ', 'Brad Cavanagh ', 'Craig DeForest ', 'Jim Lewis ', ], dist_version => '3.08', meta_merge => { 'meta-spec' => { version => 2, }, resources => { repository => { url => 'git://github.com/timj/perl-Astro-FITS-Header.git', web => 'https://github.com/timj/perl-Astro-FITS-Header/', type => 'git', }, homepage => 'https://github.com/timj/perl-Astro-FITS-Header/', }, prereqs => { runtime => { suggests => { 'Starlink::AST' => 0, }, }, }, }, recommends => { 'Astro::FITS::CFITSIO' => 0, }, build_requires => { 'Test::More' => 0, }, configure_requires => { "Module::Build" => 0.30, }, ); $build->create_build_script; Astro-FITS-Header-3.08/Changes000444004077000012 353014014777770 15502 0ustar00gbellstaff000000000000Revision history for Astro::FITS::Header 3.08 2021-02-22 - Starlink::AST recommends prereq changed to suggests. - Tied interface FIRSTKEY and CLEAR methods now handle subheaders (RT #127228). 3.07 2012-08-02 - Respect ReadOnly flag when opening FITS extensions. Fixes RT #78746 from Diab Jerius. 3.06 2012-07-13 - Minor fix to header merging to properly treat an undef card as an undef values rather than as a comment card. 3.05 2012-06-27 - Spelling fixes from debian (RT #78071) 3.04 2012-06-19 - Numeric cards with no space before the comment are now parsed correctly. - A HISTORY item is now written to NDF files when the header is updated. - The ChangeLog has been removed from this release. 3.03 2011-01-04 - Ensure that GPL is used throughout package rather than a mix of Perl licence and GPL. Fixes RT #61875 3.02 2010-12-31 - Use Module::Build 3.01 2009-03-17 - New append() method to append a header or items to an existing header, overwriting duplicates. - A header can now be constructed from a simple perl hash - Item objects now have a copy constructor. - When importing an AST frameset a specific encoding can be specified. - The Item constructor can now guess the header type. - Fixes in item removal, tied interface for history and subheaders and NDF opening when a directory has a space. 3.0 2006-08-19 - Can now select items by type using the itembytype() method. - Add equals() method. - Add ability to merge two Header objects into one. - Subheaders now supported by tie. - Fix bug RT#4816 (Diab Jerius) - change the distribution layout to be more in line with standard usage. 2.9.2 2004-03-07 - Fix tied interface to recognized proper FITS undef cards - Fix bug in comment parsing (duplicate of RT #11722) - Add optional support for Starlink::AST module Astro-FITS-Header-3.08/GPL000444004077000012 10451314014777770 14617 0ustar00gbellstaff000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . Astro-FITS-Header-3.08/MANIFEST000444004077000012 57614014777770 15327 0ustar00gbellstaff000000000000Build.PL Changes GPL lib/Astro/FITS/Header.pm lib/Astro/FITS/Header/AST.pm lib/Astro/FITS/Header/CFITSIO.pm lib/Astro/FITS/Header/GSD.pm lib/Astro/FITS/Header/Item.pm lib/Astro/FITS/Header/NDF.pm MANIFEST META.json META.yml README t/1_compile.t t/ast.t t/bugs.t t/cfitsio.fit t/cfitsio.t t/gsd.t t/hierarch.t t/item.t t/merge.t t/ndf.t t/parse.t t/subhdr.t t/test.gsd t/tied.t TODO Astro-FITS-Header-3.08/META.json000444004077000012 434414014777770 15634 0ustar00gbellstaff000000000000{ "abstract" : "Object-oriented interface to FITS HDUs", "author" : [ "Alasdair Allan ", "Tim Jenness ", "Brad Cavanagh ", "Craig DeForest ", "Jim Lewis " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4231", "license" : [ "gpl_3" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Astro-FITS-Header", "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.3" } }, "runtime" : { "recommends" : { "Astro::FITS::CFITSIO" : "0" }, "suggests" : { "Starlink::AST" : "0" } } }, "provides" : { "Astro::FITS::Header" : { "file" : "lib/Astro/FITS/Header.pm", "version" : "3.08" }, "Astro::FITS::Header::AST" : { "file" : "lib/Astro/FITS/Header/AST.pm", "version" : "3.08" }, "Astro::FITS::Header::CFITSIO" : { "file" : "lib/Astro/FITS/Header/CFITSIO.pm", "version" : "3.08" }, "Astro::FITS::Header::GSD" : { "file" : "lib/Astro/FITS/Header/GSD.pm", "version" : "3.08" }, "Astro::FITS::Header::Item" : { "file" : "lib/Astro/FITS/Header/Item.pm", "version" : "3.08" }, "Astro::FITS::Header::NDF" : { "file" : "lib/Astro/FITS/Header/NDF.pm", "version" : "3.08" }, "Astro::FITS::HeaderCollection" : { "file" : "lib/Astro/FITS/Header.pm", "version" : "3.08" } }, "release_status" : "stable", "resources" : { "homepage" : "https://github.com/timj/perl-Astro-FITS-Header/", "license" : [ "http://www.gnu.org/licenses/gpl-3.0.txt" ], "repository" : { "type" : "git", "url" : "git://github.com/timj/perl-Astro-FITS-Header.git", "web" : "https://github.com/timj/perl-Astro-FITS-Header/" } }, "version" : "3.08" } Astro-FITS-Header-3.08/META.yml000444004077000012 264614014777770 15467 0ustar00gbellstaff000000000000--- abstract: 'Object-oriented interface to FITS HDUs' author: - 'Alasdair Allan ' - 'Tim Jenness ' - 'Brad Cavanagh ' - 'Craig DeForest ' - 'Jim Lewis ' build_requires: Test::More: '0' configure_requires: Module::Build: '0.3' dynamic_config: 1 generated_by: 'Module::Build version 0.4231, CPAN::Meta::Converter version 2.143240' license: gpl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Astro-FITS-Header provides: Astro::FITS::Header: file: lib/Astro/FITS/Header.pm version: '3.08' Astro::FITS::Header::AST: file: lib/Astro/FITS/Header/AST.pm version: '3.08' Astro::FITS::Header::CFITSIO: file: lib/Astro/FITS/Header/CFITSIO.pm version: '3.08' Astro::FITS::Header::GSD: file: lib/Astro/FITS/Header/GSD.pm version: '3.08' Astro::FITS::Header::Item: file: lib/Astro/FITS/Header/Item.pm version: '3.08' Astro::FITS::Header::NDF: file: lib/Astro/FITS/Header/NDF.pm version: '3.08' Astro::FITS::HeaderCollection: file: lib/Astro/FITS/Header.pm version: '3.08' recommends: Astro::FITS::CFITSIO: '0' resources: homepage: https://github.com/timj/perl-Astro-FITS-Header/ license: http://www.gnu.org/licenses/gpl-3.0.txt repository: git://github.com/timj/perl-Astro-FITS-Header.git version: '3.08' Astro-FITS-Header-3.08/README000444004077000012 1251114014777770 15106 0ustar00gbellstaff000000000000Astro::FITS::Header module -------------------------- What is it? ----------- Astro::FITS::Header and associated sub-classes are tools for reading, modifying and then writing out FITS standard header blocks to FITS, NDF and GSD files. The module now fully supports ESO HIERARCH header keywords. Support for instantiating Astro::FITS:Header objects from Starlink::AST FrameSet objects is also supported. Full documentation is included in the POD attached to the modules. Tied Interface -------------- This is a warning for those of you using the tied interface from previous versions of the module. The interface now acts very differently, theoretically the changes shouldn't break existing code, but it has diverged sufficiently far from the original that I'm no longer convinced that it will work in all cases. Be warned! Requirements ------------ The Astro::FITS::Header module can work with FITS Header blocks, either directly from the primary FITS HDU of a file complying with the FITS data standard, or from the FITS extension in an extensible N-dimensional data format (NDF) file or from a Global Section Data file (GSD). Additionally the module also supports .HEADER in HDS contanier files, and Starlink::AST FrameSet objects. To work with FITS files, the Astro::FITS::Header module requires Pete Ratzlaff's Astro::FITS::CFITSIO library (v 1.01 or greater), which in turn requires William Pence's CFITSIO subroutine library (v2.430 or greater). It should be noted that to build the CFITSIO subroutine library on RedHat Linux 7.x you need to use version 2.202 or above, however the module requires v2.400 at least to work with the Astro::FITS::CFITSIO module. For more information on CFITSIO, see https://heasarc.gsfc.nasa.gov/fitsio/ To work with NDF, HDS and GSD files, the Astro::FITS::Header module requires Tim Jenness' NDF (version 1.42 or greater) and GSD modules. These modules are installed as part of the PERLMODS package in the Starlink Software Collection. To work with AST FrameSet objects the Starlink::AST module is required, this module (should) be available from CPAN or by contacting the authors of this package. For more information on the Starlink Software Collection and the Starlink Project in general see https://www.starlink.ac.uk/ Provides -------- The package provides the following classes Astro::FITS::Header Astro::FITS::Header::Item Astro::FITS::Header::NDF Astro::FITS::Header::CFITSIO Astro::FITS::Header::GSD Astro::FITS::Header::AST which all include POD format documentation. Where can I get it? ------------------- The package is available from CPAN Installation ------------ Installation is automated using the ExtUtils::MakeMaker library % perl Build.PL % ./Build % ./Build test % ./Build install If the Astro::FITS::CFITSIO, NDF or Starlink::AST modules are not installed 'make test' will detect this and skip the test harness for the relevant modules with a warning. Note on Versioning --------------- Due to misunderstandings on the CPAN versioning scheme all modules in this release have jumped to version >= 3.0 to force reindexing. Patch numbers are no longer included in the distribution. Authors ------- The module was originally written by Alasdair Allan , of the University of Exeter Astrophysics Group (http://www.astro.ex.ac.uk/) as part of his work for the Starlink Project (http://www.starlink.ac.uk/), and Tim Jenness of the Joint Astronomy Center (JAC) (http://www.jach.hawaii.edu/) in Hawaii. This version of the module includes patches supplied by Diab Jerius , of the Harvard-Smithsonian Center for Astrophysics, and by Jim Lewis , of the Cambridge Astronomy Survey Unit at the Institute of Astronomy, to allow access to Multi-Extension FITS files. The tied interface was updated for version 2.x by Craig DeForest of the Department of Space Studies, Southwest Research Institute and Tim Jenness of the Joint Astronomy Center (JAC) in Hawaii. Patches to fix some bugs in the tied interface when dealing with blank cards were supplied by Brad Cavangh of the Joint Astronomy Center (JAC) in Hawaii. Modifications to parse ESO HIERARCH keywords, read-only, were added by Malcolm Currie of the Rutherford Appleton Laboratory. Maintainer ---------- The package is currently maintained by Tim Jenness . Please use CPAN RT for bug reports and github pull requests for patches. The source code repository is at git://github.com/timj/perl-Astro-FITS-Header.git License ------- This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful,but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place,Suite 330, Boston, MA 02111-1307, USA Astro-FITS-Header-3.08/TODO000444004077000012 37314014777770 14661 0ustar00gbellstaff000000000000To Do ----- - Add ability for units to be extracted from item comments - Read HISTORY from NDF and merge it into FITS header. On writing the merged HISTORY should be writing to the HISTORY extension of the NDF as this is regarded as canonical. Astro-FITS-Header-3.08/lib000755004077000012 014014777770 14617 5ustar00gbellstaff000000000000Astro-FITS-Header-3.08/lib/Astro000755004077000012 014014777770 15707 5ustar00gbellstaff000000000000Astro-FITS-Header-3.08/lib/Astro/FITS000755004077000012 014014777770 16454 5ustar00gbellstaff000000000000Astro-FITS-Header-3.08/lib/Astro/FITS/Header.pm000444004077000012 13671214014777770 20411 0ustar00gbellstaff000000000000package Astro::FITS::Header; # --------------------------------------------------------------------------- =head1 NAME Astro::FITS::Header - Object Orientated interface to FITS HDUs =head1 SYNOPSIS $header = new Astro::FITS::Header( Cards => \@array ); =head1 DESCRIPTION Stores information about a FITS header block in an object. Takes an hash with an array reference as an argument. The array should contain a list of FITS header cards as input. =cut # L O A D M O D U L E S -------------------------------------------------- use strict; use vars qw/ $VERSION /; use Carp; use Astro::FITS::Header::Item; $VERSION = 3.08; # Operator overloads use overload '""' => "stringify", fallback => 1; # C O N S T R U C T O R ---------------------------------------------------- =head1 METHODS =head2 Constructor =over 4 =item B Create a new instance from an array of FITS header cards. $item = new Astro::FITS::Header( Cards => \@header ); returns a reference to a Header object. If you pass in no cards, you get the (required) first SIMPLE card for free. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; # bless the header block into the class my $block = bless { HEADER => [], LOOKUP => {}, LASTKEY => undef, TieRetRef => 0, SUBHDRS => [], }, $class; # Configure the object, even with no arguments since configure # still puts the minimum SIMPLE card in. $block->configure( @_ ); return $block; } # I T E M ------------------------------------------------------------------ =back =head2 Accessor Methods =over 4 =item B Indicates whether the tied object should return multiple values as a single string joined by newline characters (false) or it should return a reference to an array containing all the values. Only affects the tied interface. tie %keywords, "Astro::FITS::Header", $header, tiereturnsref => 1; $ref = $keywords{COMMENT}; Defaults to returning a single string in all cases (for backwards compatibility) =cut sub tiereturnsref { my $self = shift; if (@_) { $self->{TieRetRef} = shift; } return $self->{TieRetRef}; } =item B Set or return the subheaders for a Header object. Arguments must be given as C objects. $header->subhdrs(@hdrs); @hdrs = $header->subhdrs; This method should be used when you have additional header components that should be associated with the primary header but they are not associated with a particular name, just an ordering. FITS headers that are associated with a name can be stored directly in the header using an C of type 'HEADER'. =cut sub subhdrs { my $self = shift; if (@_) { # verify the class my $i; for my $h (@_) { croak "Argument $i supplied to subhdrs method is not a Astro::FITS::Header object\n" unless UNIVERSAL::isa( $h, "Astro::FITS::Header" ); $i++; } # store them @{$self->{SUBHDRS}} = @_; } if (wantarray()) { return @{$self->{SUBHDRS}}; } else { return $self->{SUBHDRS}; } } =item B Returns a FITS::Header:Item object referenced by index, C if it does not exist. $item = $header->item($index); =cut sub item { my ( $self, $index ) = @_; return undef unless defined $index; return undef unless exists ${$self->{HEADER}}[$index]; # grab and return the Header::Item at $index return ${$self->{HEADER}}[$index]; } =item B Returns a Starlink::AST FrameSet object representing the WCS of the FITS Header. $ast = $header->get_wcs(); =cut sub get_wcs { my $self = shift; require Starlink::AST; my $fchan = Starlink::AST::FitsChan->new(); for my $i ( $self->cards() ) { $fchan->PutFits( $i, 0); } $fchan->Clear( "Card" ); return $fchan->Read(); } # K E Y W O R D ------------------------------------------------------------ =item B Returns keyword referenced by index, C if it does not exist. $keyword = $header->keyword($index); =cut sub keyword { my ( $self, $index ) = @_; return undef unless defined $index; return undef unless exists ${$self->{HEADER}}[$index]; # grab and return the keyword at $index return ${$self->{HEADER}}[$index]->keyword(); } # I T E M B Y N A M E ------------------------------------------------- =item B Returns an array of Header::Items for the requested keyword if called in list context, or the first matching Header::Item if called in scalar context. Returns C if the keyword does not exist. The keyword may be a regular expression created with the C operator. @items = $header->itembyname($keyword); $item = $header->itembyname($keyword); =cut sub itembyname { my ( $self, $keyword ) = @_; my @items = @{$self->{HEADER}}[$self->index($keyword)]; return wantarray ? @items : @items ? $items[0] : undef; } # I T E M B Y T Y P E ------------------------------------------------- =item B Returns an array of Header::Items for the requested type if called in list context, or the first matching Header::Item if called in scalar context. See C for a list of allowed types. @items = $header->itembytype( "COMMENT" ); @items = $header->itembytype( "HEADER" ); $item = $header->itembytype( "INT" ); =cut sub itembytype { my ( $self, $type ) = @_; return () unless defined $type; $type = uc($type); # No optimised lookup so brute force it my @items = grep { $_->type eq $type } @{ $self->{HEADER} }; return wantarray ? @items : @items ? $items[0] : undef; } # I N D E X -------------------------------------------------------------- =item B Returns an array of indices for the requested keyword if called in list context, or an empty array if it does not exist. The keyword may be a regular expression created with the C operator. @index = $header->index($keyword); If called in scalar context it returns the first item in the array, or C if the keyword does not exist. $index = $header->index($keyword); =cut sub index { my ( $self, $keyword ) = @_; # grab the index array from lookup table my @index; if ( 'Regexp' eq ref $keyword ) { push @index, @{$self->{LOOKUP}{$_}} foreach grep { /$keyword/ && defined $self->{LOOKUP}{$_} } keys %{$self->{LOOKUP}}; @index = sort @index; } else { @index = @{${$self->{LOOKUP}}{$keyword}} if ( exists ${$self->{LOOKUP}}{$keyword} && defined ${$self->{LOOKUP}}{$keyword} ); } # return the values array return wantarray ? @index : @index ? $index[0] : undef; } # V A L U E --------------------------------------------------------------- =item B Returns an array of values for the requested keyword if called in list context, or an empty array if it does not exist. The keyword may be a regular expression created with the C operator. @value = $header->value($keyword); If called in scalar context it returns the first item in the array, or C if the keyword does not exist. =cut sub value { my ( $self, $keyword ) = @_; # resolve the values from the index array from lookup table my @values = map { ${$self->{HEADER}}[$_]->value() } $self->index($keyword); # loop over the indices and grab the values return wantarray ? @values : @values ? $values[0] : undef; } # C O M M E N T ------------------------------------------------------------- =item B Returns an array of comments for the requested keyword if called in list context, or an empty array if it does not exist. The keyword may be a regular expression created with the C operator. @comment = $header->comment($keyword); If called in scalar context it returns the first item in the array, or C if the keyword does not exist. $comment = $header->comment($keyword); =cut sub comment { my ( $self, $keyword ) = @_; # resolve the comments from the index array from lookup table my @comments = map { ${$self->{HEADER}}[$_]->comment() } $self->index($keyword); # loop over the indices and grab the comments return wantarray ? @comments : @comments ? $comments[0] : undef; } # I N S E R T ------------------------------------------------------------- =item B Inserts a FITS header card object at position $index $header->insert($index, $item); the object $item is not copied, multiple inserts of the same object mean that future modifications to the one instance of the inserted object will modify all inserted copies. The insert position can be negative. =cut sub insert{ my ($self, $index, $item) = @_; # splice the new FITS header card into the array # Splice automatically triggers a lookup table rebuild $self->splice($index, 0, $item); return; } # R E P L A C E ------------------------------------------------------------- =item B Replace FITS header card at index $index with card $item $card = $header->replace($index, $item); returns the replaced card. =cut sub replace{ my ($self, $index, $item) = @_; # remove the specified item and replace with $item # Splice triggers a rebuild so we do not have to return $self->splice( $index, 1, $item); } # R E M O V E ------------------------------------------------------------- =item B Removes a FITS header card object at position $index $card = $header->remove($index); returns the removed card. =cut sub remove{ my ($self, $index) = @_; # remove the FITS header card from the array # Splice always triggers a lookup table rebuild so we don't have to return $self->splice( $index, 1); } # R E P L A C E B Y N A M E --------------------------------------------- =item B Replace FITS header cards with keyword $keyword with card $item $card = $header->replacebyname($keyword, $item); returns the replaced card. The keyword may be a regular expression created with the C operator. =cut sub replacebyname{ my ($self, $keyword, $item) = @_; # grab the index array from lookup table my @index = $self->index($keyword); # loop over the keywords # We use a real splice rather than the class splice for efficiency # in order to prevent an index rebuild for each index my @cards = map { splice @{$self->{HEADER}}, $_, 1, $item;} @index; # force rebuild $self->_rebuild_lookup; # return removed items return wantarray ? @cards : $cards[scalar(@cards)-1]; } # R E M O V E B Y N A M E ----------------------------------------------- =item B Removes a FITS header card object by name @card = $header->removebyname($keyword); returns the removed cards. The keyword may be a regular expression created with the C operator. =cut sub removebyname{ my ($self, $keyword) = @_; # grab the index array from lookup table my @index = $self->index($keyword); # loop over the keywords # We use a real splice rather than the class splice for efficiency # in order to prevent an index rebuild for each index. The ugly code # is needed in case we have multiple indices returned, which can # happen if we have a regular expression passed in as a keyword. my $i = -1; my @cards = map { $i++; splice @{$self->{HEADER}}, ( $_ - $i ), 1; } sort @index; # force rebuild $self->_rebuild_lookup; # return removed items return wantarray ? @cards : $cards[scalar(@cards)-1]; } # S P L I C E -------------------------------------------------------------- =item B Implements a standard splice operation for FITS headers @cards = $header->splice($offset [,$length [, @list]]); $last_card = $header->splice($offset [,$length [, @list]]); Removes the FITS header cards from the header designated by $offset and $length, and replaces them with @list (if specified) which must be an array of FITS::Header::Item objects. Returns the cards removed. If offset is negative, counts from the end of the FITS header. =cut sub splice { my $self = shift; my ($offset, $length, @list) = @_; # If the array is empty and we get a negative offset we # must convert it to an offset of 0 to prevent a: # Modification of non-creatable array value attempted, subscript -1 # fatal error # This can occur with a tied hash and the %{$tieref} = %new # construct if (defined $offset) { $offset = 0 if (@{$self->{HEADER}} == 0 && $offset < 0); } # the removed cards my @cards; if (@list) { # all arguments supplied my $n = 0; for my $i (@list) { croak "Argument $n to splice must be Astro::FITS::Header::Item objects" unless UNIVERSAL::isa($i, "Astro::FITS::Header::Item"); $n++; } @cards = splice @{$self->{HEADER}}, $offset, $length, @list; } elsif (defined $length) { # length and (presumably) offset @cards = splice @{$self->{HEADER}}, $offset, $length; } elsif (defined $offset) { # offset only @cards = splice @{$self->{HEADER}}, $offset; } else { # none @cards = splice @{$self->{HEADER}}; } # update the internal lookup table and return $self->_rebuild_lookup(); return wantarray ? @cards : $cards[scalar(@cards)-1]; } # C A R D S -------------------------------------------------------------- =item B Return the object contents as an array of FITS cards. @array = $header->cards; =cut sub cards { my $self = shift; return map { "$_" } @{$self->{HEADER}}; } =item B Returns the highest index in use in the FITS header. To get the total number of header items, add 1. $number = $header->sizeof; =cut sub sizeof { my $self = shift; return $#{$self->{HEADER}}; } # A L L I T E M S --------------------------------------------------------- =item B Returns the header as an array of FITS::Header:Item objects. @items = $header->allitems(); =cut sub allitems { my $self = shift; return map { $_ } @{$self->{HEADER}}; } # C O N F I G U R E ------------------------------------------------------- =back =head2 General Methods =over 4 =item B Configures the object, takes an array of FITS header cards, an array of Astro::FITS::Header::Item objects or a simple hash as input. If you feed in nothing at all, it uses a default array containing just the SIMPLE card required at the top of all FITS files. $header->configure( Cards => \@array ); $header->configure( Items => \@array ); $header->configure( Hash => \%hash ); Does nothing if the array is not supplied. If the hash scheme is used and the hash contains the special key of SUBHEADERS pointing to an array of hashes, these will be read as proper sub headers. All other references in the hash will be ignored. Note that the default key order will be retained in the object created via the hash. =cut sub configure { my $self = shift; # grab the argument list my %args = @_; if (exists $args{Cards} && defined $args{Cards}) { # First translate each incoming card into a Item object # Any existing cards are removed @{$self->{HEADER}} = map { new Astro::FITS::Header::Item( Card => $_ ); } @{ $args{Cards} }; # Now build the lookup table. There would be a slight efficiency # gain to include this in a loop over the cards but prefer # to reuse the method for this rather than repeating code $self->_rebuild_lookup; } elsif (exists $args{Items} && defined $args{Items}) { # We have an array of Astro::FITS::Header::Items @{$self->{HEADER}} = @{ $args{Items} }; $self->_rebuild_lookup; } elsif (exists $args{Hash} && defined $args{Hash} ) { # we have a hash so convert to Item objects and store # use a For loop instead of map since we want to # skip some items croak "Hash constructor requested but not given a hash reference" unless ref($args{Hash}) eq 'HASH'; my @items; my @subheaders; for my $k (keys %{$args{Hash}}) { if ($k eq 'SUBHEADERS' && ref($args{Hash}->{$k}) eq 'ARRAY' && ref($args{Hash}->{$k}->[0]) eq 'HASH') { # special case @subheaders = map { $self->new( Hash => $_ ) } @{$args{Hash}->{$k}}; } elsif (not ref($args{Hash}->{$k})) { # if we have new lines in the value, we should duplicate the item # so split on new lines my $value = $args{Hash}->{$k}; $value = '' unless defined $value; my @lines = split(/^/m,$value); chomp(@lines); # remove the newlines push(@items, map { new Astro::FITS::Header::Item( Keyword => $k, Value => $_ ) } @lines); } } @{$self->{HEADER}} = @items; $self->_rebuild_lookup; $self->subhdrs(@subheaders) if @subheaders; } elsif ( !defined($self->{HEADER}) || !@{$self->{HEADER}} ) { @{$self->{HEADER}} = ( new Astro::FITS::Header::Item( Card=> "SIMPLE = T"), new Astro::FITS::Header::Item( Card=> "END", Type=>"END" ) ); $self->_rebuild_lookup; } } =item B Given the current header and a set of C objects, return a merged FITS header (with the cards that have the same value and comment across all headers) along with, for each input, header objects containing all the header items that differ (including, by default, keys that are not present in all headers). Only the primary headers are merged, subheaders are ignored. ($clone) = $headerr->merge_primary(); ($same, @different) = $header->merge_primary( $fits1, $fits2, ...); ($same, @different) = $header->merge_primary( \%options, $fits1, $fits2 ); @different can be empty if all headers match (but see the C option) but if any headers are different there will always be the same number of headers in @different as supplied to the function (including the reference header). A clone of the input header (stripped of any subheaders) is returned if no comparison headers are supplied. In scalar context, just returns the merged header. $merged = $header->merge_primary( @hdrs ); The options hash is itself optional. It contains the following keys: merge_unique - if an item is identical across multiple headers and only exists in those headers, propogate to the merged header rather than storing it in the difference headers. force_return_diffs - return an empty difference object per input header even if there are no diffs =cut sub merge_primary { my $self = shift; # optional options handling my %opt = ( merge_unique => 0, force_return_diffs => 0, ); if (ref($_[0]) eq 'HASH') { my $o = shift; %opt = ( %opt, %$o ); } # everything else is fits headers # If we do not get any additional headers we still process the full header # rather than shortcircuiting the logic. This is so that we can strip # HEADER items without having to write duplicate logic. Clearly not # very efficient but we do not really expect people to use this method # to clone a FITS header.... my @fits = @_; # Number of output diff arrays # Include this object my $nhdr = @fits + 1; # Go through all the items building up a hash indexed # by KEYWORD pointing to an array of items with that keyword # and an array of unique keywords in the original order they # appeared first. COMMENT items are stored in the # hash as complete cards. # HEADER items are currently dropped on the floor. my @order; my %items; my $hnum = 0; for my $hdr ($self, @fits) { for my $item ($hdr->allitems) { my $key; my $type = $item->type; if (!defined $type || $type eq 'BLANK') { # blank line so skip it next; } elsif ($type eq 'COMMENT') { $key = $item->card; } elsif ($type eq 'HEADER') { next; } else { $key = $item->keyword; } if (exists $items{$key}) { # Store the item, but in a hash with key corresponding # to the input header number push( @{ $items{$key}}, { item => $item, hnum => $hnum } ); } else { $items{$key} = [ { item => $item, hnum => $hnum } ]; push(@order, $key); } } $hnum++; } # create merged and difference arrays my @merged; my @difference = map { [] } (1..$nhdr); # Now loop over all of the unique keywords (taking care to # spot comments) for my $key (@order) { my @items = @{$items{$key}}; # compare each Item with the first. This will work even if we only have # one Item in the array. # Note that $match == 1 to start with because it always matches itself # but we do not bother doing the with-itself comparison. my $match = 1; for my $i (@items[1..$#items]) { # Ask the Items to compare using the equals() method if ($items[0]->{item}->equals( $i->{item} )) { $match++; } } # if we matched all the items and are merging unique OR if we # matched all the items and that was all the available headers # we store in the merged array. Else we store in the differences # array if ($match == @items && ($match == $nhdr || $opt{merge_unique})) { # Matched all the headers or merging matching unique headers # only need to store one push(@merged, $items[0]->{item}); } else { # Not enough of the items matched. Store to the relevant difference # arrays. for my $i (@items) { push(@{ $difference[$i->{hnum}] }, $i->{item}); } } } # and clear @difference in the special case where none have any headers if (!$opt{force_return_diffs}) { @difference = () unless grep { @$_ != 0 } @difference; } # unshift @merged onto the front of @difference in preparation # for returning it unshift(@difference, \@merged ); # convert back to FITS object, Construct using the Items directly # - they will be copied without strinfication. for my $d (@difference) { $d = $self->new( Cards => $d ); } # remembering that the merged array is on the front return (wantarray ? @difference : $difference[0]); } =item B Method to return a blessed reference to the object so that we can store ths object on disk using Data::Dumper module. =cut sub freeze { my $self = shift; return bless $self, 'Astro::FITS::Header'; } =item B Append or update a card. $header->append( $card ); This method can take either an Astro::FITS::Header::Item object, an Astro::FITS::Header object, or a reference to an array of Astro::FITS::Header::Item objects. In all cases, if the given Astro::FITS::Header::Item keyword exists in the header, then the value will be overwritten with the one passed to the method. Otherwise, the card will be appended to the end of the header. Nothing is returned. =cut sub append { my $self = shift; my $thing = shift; my @cards; if ( UNIVERSAL::isa( $thing, "Astro::FITS::Header::Item" ) ) { push @cards, $thing; } elsif ( UNIVERSAL::isa( $thing, "Astro::FITS::Header" ) ) { @cards = $thing->allitems; } elsif ( ref( $thing ) eq 'ARRAY' ) { @cards = @$thing; } foreach my $card ( @cards ) { my $item = $self->itembyname( $card->keyword ); if ( defined( $item ) ) { # Update the given card. $self->replacebyname( $card->keyword, $card ) } else { # Don't append a SIMPLE header as that can lead to disaster and # strife and gnashing of teeth (and violates the FITS standard). next if ( uc( $card->keyword ) eq 'SIMPLE' ); # Retrieve the index of the END card, and insert this card # before that one, but only if the END header actually exists. my $index = $self->index( 'END' ); $index = ( defined( $index ) ? $index : -1 ); $self->insert( $index, $card ); } } $self->_rebuild_lookup; } # P R I V A T E M E T H O D S ------------------------------------------ =back =head2 Operator Overloading These operators are overloaded: =over 4 =item B<""> When the object is used in a string context the FITS header block is returned as a single string. =cut sub stringify { my $self = shift; return join("\n", $self->cards )."\n"; } =back =head2 Private methods These methods are for internal use only. =over 4 =item B<_rebuild_lookup> Private function used to rebuild the lookup table after modifying the header block, its easier to do it this way than go through and add one to the indices of all header cards following the modifed card. =cut sub _rebuild_lookup { my $self = shift; # rebuild the lookup table # empty the hash $self->{LOOKUP} = { }; # loop over the existing header array for my $j (0 .. $#{$self->{HEADER}}) { # grab the keyword from each header item; my $key = ${$self->{HEADER}}[$j]->keyword(); # need to account to repeated keywords (e.g. COMMENT) unless ( exists ${$self->{LOOKUP}}{$key} && defined ${$self->{LOOKUP}}{$key} ) { # new keyword ${$self->{LOOKUP}}{$key} = [ $j ]; } else { # keyword exists, push the current index into the array push( @{${$self->{LOOKUP}}{$key}}, $j ); } } } # T I E D I N T E R F A C E ----------------------------------------------- =back =head1 TIED INTERFACE The C object can also be tied to a hash: use Astro::FITS::Header; $header = new Astro::FITS::Header( Cards => \@array ); tie %hash, "Astro::FITS::Header", $header $value = $hash{$keyword}; $hash{$keyword} = $value; print "keyword $keyword is present" if exists $hash{$keyword}; foreach my $key (keys %hash) { print "$key = $hash{$key}\n"; } =head2 Basic hash translation Header value type is determined on-the-fly by parsing of the input values. Anything that parses as a number or a logical is converted to that before being put in a card (but see below). Per-card comment fields can be accessed using the tied interface by specifying a key name of "key_COMMENT". This works because in general "_COMMENT" is too long to be confused with a normal key name. $comment = $hdr{CRPIX1_COMMENT}; will return the comment associated with CRPIX1 header item. The comment can be modified in the same way: $hdr{CRPIX1_COMMENT} = "An axis"; You can also modify the comment by slash-delimiting it when setting the associated keyword: $hdr{CRPIX1} = "34 / Set this field manually"; If you want an actual slash character in your string field you must escape it with a backslash. (If you're in double quotes you have to use a double backslash): $hdr{SLASHSTR} = 'foo\/bar / field contains "foo/bar"'; Keywords are CaSE-inNSEnSiTIvE, unlike normal hash keywords. All keywords are translated to upper case internally, per the FITS standard. Aside from the SIMPLE and END keywords, which are automagically placed at the beginning and end of the header respectively, keywords are included in the header in the order received. This gives you a modicum of control over card order, but if you actually care what order they're in, you probably don't want the tied interface. =head2 Comment cards Comment cards are a special case because they have no normal value and their comment field is treated as the hash value. The keywords "COMMENT" and "HISTORY" are magic and refer to comment cards; nearly all other keywords create normal valued cards. (see "SIMPLE and END cards", below). =head2 Multi-card values Multiline string values are broken up, one card per line in the string. Extra-long string values are handled gracefully: they get split among multiple cards, with a backslash at the end of each card image. They're transparently reassembled when you access the data, so that there is a strong analogy between multiline string values and multiple cards. In general, appending to hash entries that look like strings does what you think it should. In particular, comment cards have a newline appended automatically on FETCH, so that $hash{HISTORY} .= "Added multi-line string support"; adds a new HISTORY comment card, while $hash{TELESCOP} .= " dome B"; only modifies an existing TELESCOP card. You can make multi-line values by feeding in newline-delimited strings, or by assigning from an array ref. If you ask for a tag that has a multiline value it's always expanded to a multiline string, even if you fed in an array ref to start with. That's by design: multiline string expansion often acts as though you are getting just the first value back out, because perl string-to-number conversion stops at the first newline. So: $hash{CDELT1} = [3,4,5]; print $hash{CDELT1} + 99,"\n$hash{CDELT1}"; prints "102\n3\n4\n5", and then $hash{CDELT1}++; print $hash{CDELT1}; prints "4". In short, most of the time you get what you want. But you can always fall back on the non-tied interface by calling methods like so: ((tied $hash)->method()) If you prefer to have multi-valued items automagically become array refs, then you can get that behavior using the C method: tie %keywords, "Astro::FITS::Header", $header, tiereturnsref => 1; When tiereturnsref is true, multi-valued items will be returned via a reference to an array (ties do not respect calling context). Note that if this is configured you will have to test each return value to see whether it is returning a real value or a reference to an array if you are not sure whether there will be more than one card with a duplicate name. =head2 Type forcing Because perl uses behind-the-scenes typing, there is an ambiguity between strings and numeric and/or logical values: sometimes you want to create a STRING card whose value could parse as a number or as a logical value, and perl kindly parses it into a number for you. To force string evaluation, feed in a trivial array ref: $hash{NUMSTR} = 123; # generates an INT card containing 123. $hash{NUMSTR} = "123"; # generates an INT card containing 123. $hash{NUMSTR} = ["123"]; # generates a STRING card containing "123". $hash{NUMSTR} = [123]; # generates a STRING card containing "123". $hash{ALPHA} = "T"; # generates a LOGICAL card containing T. $hash{ALPHA} = ["T"]; # generates a STRING card containing "T". Calls to keys() or each() will, by default, return the keywords in the order in which they appear in the header. =head2 Sub-headers When the key refers to a subheader entry (ie an item of type "HEADER"), a hash reference is returned. If a hash reference is stored in a value it is converted to a C object. If the special key "SUBHEADERS" is used, it will return the array of subheaders, (as stored using the C method) each of which will be tied to a hash. Subheaders can be stored using normal array operations. =head2 SIMPLE and END cards No FITS interface would becomplete without special cases. When you assign to SIMPLE or END, the tied interface ensures that they are first or last, respectively, in the deck -- as the FITS standard requires. Other cards are inserted in between the first and last elements, in the order that you define them. The SIMPLE card is forced to FITS LOGICAL (boolean) type. The FITS standard forbids you from setting it to F, but you can if you want -- we're not the FITS police. The END card is forced to a null type, so any value you assign to it will fall on the floor. If present in the deck, the END keyword always contains the value " ", which is both more-or-less invisible when printed and also true -- so you can test the return value to see if an END card is present. SIMPLE and END come pre-defined from the constructor. If for some nefarious reason you want to remove them you must explicitly do so with "delete" or the appropriate method call from the object interface. =cut # List of known comment-type fields %Astro::FITS::Header::COMMENT_FIELD = ( "COMMENT"=>1, "HISTORY"=>1 ); # constructor sub TIEHASH { my ( $class, $obj, %options ) = @_; my $newobj = bless $obj, $class; # Process options for my $key (keys %options) { my $method = lc($key); if ($newobj->can($method)) { $newobj->$method( $options{$key}); } } return $newobj; } # fetch key and value pair # MUST return undef if the key is missing else autovivification of # sub header will fail sub FETCH { my ($self, $key) = @_; $key = uc($key); # if the key is called SUBHEADERS we should tie to an array if ($key eq 'SUBHEADERS') { my @dummy; tie @dummy, "Astro::FITS::HeaderCollection", scalar $self->subhdrs; return \@dummy; } # If the key has a _COMMENT suffix we are looking for a comment my $wantvalue = 1; my $wantcomment = 0; if ($key =~ /_COMMENT$/) { $wantvalue = 0; $wantcomment = 1; # Remove suffix $key =~ s/_COMMENT$//; } # if we are of type COMMENT we want to retrieve the comment only # if they're asking for $key_COMMENT. my $item; my $t_ok; if ( $wantcomment || $key =~ /^(COMMENT)|(HISTORY)$/ || $key =~ /^END$/) { $item = ($self->itembyname($key))[0]; $t_ok = (defined $item) && (defined $item->type); $wantvalue = 0 if ($t_ok && ($item->type eq 'COMMENT')); } # The END card is a special case. We always return " " for the value, # and undef for the comment. return ($wantvalue ? " " : undef) if ( ($t_ok && ($item->type eq 'END')) || ((defined $item) && ($key eq 'END')) ); # Retrieve all the values/comments. Note that we go through the entire # header for this in case of multiple matches my @values = ($wantvalue ? $self->value( $key ) : $self->comment($key) ); # Return value depends on return context. If we have one value it does not # matter, just return it. In list context want all the values, in scalar # context join them all with a \n # Note that in a TIED hash we do not have access to the calling context # we are ALWAYS in scalar context. my @out; # Sometimes we want the array to remain an array if ($self->tiereturnsref) { @out = @values; } else { # Join everything together with a newline # BUT we are careful here to prevent stringification of references # at least for the case where we only have one value. We also must # handle the case where we have no value to return (without turning # it into a null string since that ruins autovivification of sub headers) if (scalar(@values) <= 1) { @out = @values; } else { # Multi values so join [protecting warnings from undef] @out = ( join("\n", map { defined $_ ? $_ : '' } @values) ); # This is a hangover from the STORE (where we add a \ continuation # character to multiline strings) $out[0] =~ s/\\\n//gs if (defined($out[0])); } } # COMMENT cards get a newline appended. # (Whether this should happen is controversial, but it supports # the "just append a string to get a new COMMENT card" behavior # described in the documentation). if ($t_ok && ($item->type eq 'COMMENT')) { @out = map { $_ . "\n" } @out; } # If we have a header we need to tie it to another hash my $ishdr = ($t_ok && $item->type eq 'HEADER'); for my $hdr (@out) { if ((UNIVERSAL::isa($hdr, "Astro::FITS::Header")) || $ishdr) { my %header; tie %header, ref($hdr), $hdr; # Change in place $hdr = \%header; } } # Can only return a scalar # So return the first value if tiereturnsref is false. # (by this point, all the values should be joined together into the # first element anyway.) my $out; if ($self->tiereturnsref && scalar(@out) > 1) { $out = \@out; } else { $out = $out[0]; } return $out; } # store key and value pair # # Multiple-line kludges (CED): # # * Array refs get handled gracefully by being put in as multiple cards. # # * Multiline strings get broken up and put in as multiple cards. # # * Extra-long strings get broken up and put in as multiple cards, with # an extra backslash at the end so that they transparently get put back # together upon retrieval. # sub STORE { my ($self, $keyword, $value) = @_; my @values; # Recognize slash-delimited comments in value keywords. This is done # cheesily via recursion -- would be more efficient, but less readable, # to propagate the comment through the code... # I think this is fundamentally flawed. If I store a string "foo/bar" # in a hash and then read it back I expect to get "foo/bar" not "foo". # I can not be expected to know that this hash happens to be tied to # a FITS header that is trying to spot FITS item formatting. - TJ # Make sure that we do not stringify reference arguments by mistake # when looking from slashes if (defined $value && !ref($value) && $keyword !~ m/(_COMMENT$)|(^(COMMENT|HISTORY)$)/ and $value =~ s:\s*(?new( Hash => $value ) ); } } elsif ((ref $value eq 'ARRAY') || (length $value > 70) || $value =~ m/\n/s ) { my @val; # @val gets intermediate breakdowns, @values gets line-by-line breakdowns. # Change multiline strings into array refs if (ref $value eq 'ARRAY') { @val = @$value; } elsif (ref $value) { croak "Can't put non-array ref values into a tied FITS header\n"; } elsif ( $value =~ m/\n/s ) { @val = split("\n",$value); chomp @val; } else { @val = $value; } # Cut up really long items into multiline strings my($val); foreach $val(@val) { while ((length $val) > 70) { push(@values,substr($val,0,69)."\\"); $val = substr($val,69); } push(@values,$val); } } ## End of complicated case else { @values = ($value); } # Upper case the relevant item name $keyword = uc($keyword); if ($keyword eq 'END') { # Special case for END keyword # (drops value on floor, makes sure there is one END at the end) my @index = $self->index($keyword); if ( @index != 1 || $index[0] != $#{$self->allitems}) { my $i; while (defined($i = shift @index)) { $self->remove($i); } } unless( @index ) { my $endcard = new Astro::FITS::Header::Item(Keyword=>'END', Type=>'END', Value=>1); $self->insert( scalar ($self->allitems) , $endcard ); } return; } if ($keyword eq 'SIMPLE') { # Special case for SIMPLE keyword # (sets value correctly, makes sure there is one SIMPLE at the beginning) my @index = $self->index($keyword); if ( @index != 1 || $index[0] != 0) { my $i; while (defined ($i=shift @index)) { $self->remove($i); } } unless( @index ) { my $simplecard = new Astro::FITS::Header::Item(Keyword=>'SIMPLE', Value=>$values[0], Type=>'LOGICAL'); $self->insert(0, $simplecard); } return; } # Recognise _COMMENT my $havevalue = 1; if ($keyword =~ /_COMMENT$/) { $keyword =~ s/_COMMENT$//; $havevalue = 0; } my @items = $self->itembyname($keyword); ## Remove extra items if necessary if (scalar(@items) > scalar(@values)) { my(@indices) = $self->index($keyword); my($i); for $i (1..(scalar(@items) - scalar(@values))) { $self->remove( $indices[-$i] ); } } ## Allocate new items if necessary while (scalar(@items) < scalar(@values)) { my $item = new Astro::FITS::Header::Item(Keyword=>$keyword,Value=>undef); # (No need to set type here; Item does it for us) $self->insert(-1,$item); push(@items,$item); } ## Set values or comments my($i); for $i(0..$#values) { if ($Astro::FITS::Header::COMMENT_FIELD{$keyword}) { $items[$i]->type('COMMENT'); $items[$i]->comment($values[$i]); } elsif (! $havevalue) { # This is actually just changing the comment $items[$i]->comment($values[$i]); } else { $items[$i]->type( (($#values > 0) || ref $value) ? 'STRING' : undef); $items[$i]->value($values[$i]); $items[$i]->type("STRING") if($#values > 0); } } } # reports whether a key is present in the hash # SUBHEADERS only exist if there are subheaders sub EXISTS { my ($self, $keyword) = @_; $keyword = uc($keyword); if ($keyword eq 'SUBHEADERS') { return ( scalar(@{$self->subhdrs}) > 0 ? 1 : 0); } if ( !exists( ${$self->{LOOKUP}}{$keyword} ) ) { return undef; } # if we are being asked for a keyword that is associated with a COMMENT or BLANK # type we return FALSE for existence. An undef type means we have to assume a valid # item with unknown type if ( exists( ${$self->{LOOKUP}}{$keyword} ) ) { my $item = ${$self->{HEADER}}[${$self->{LOOKUP}}{$keyword}[0]]; my $type = $item->type; return undef if (defined $type && ($type eq 'COMMENT' || $type eq 'BLANK') ); } return 1; } # deletes a key and value pair sub DELETE { my ($self, $keyword) = @_; return $self->removebyname($keyword); } # empties the hash sub CLEAR { my $self = shift; $self->{HEADER} = [ ]; $self->{LOOKUP} = { }; $self->{LASTKEY} = undef; $self->{SEENKEY} = undef; $self->{SUBHDRS} = [ ]; } # implements keys() and each() sub FIRSTKEY { my $self = shift; $self->{LASTKEY} = 0; $self->{SEENKEY} = {}; return $self->_check_for_subhdr() unless @{$self->{HEADER}}; return ${$self->{HEADER}}[0]->keyword(); } # implements keys() and each() sub NEXTKEY { my ($self, $keyword) = @_; # abort if the number of keys we have served equals the number in the # header array. One wrinkle is that if we have SUBHDRS we want to go # round one more time if ($self->{LASTKEY}+1 == scalar(@{$self->{HEADER}})) { return $self->_check_for_subhdr(); } # Skip later lines of multi-line cards since the tie interface # will return all the lines for a single keyword request. my($a); do { $self->{LASTKEY} += 1; $a = $self->{HEADER}->[$self->{LASTKEY}]; # Got to end of header if we do not have $a return $self->_check_for_subhdr() unless defined $a; } while ( $self->{SEENKEY}->{$a->keyword}); $a = $a->keyword; $self->{SEENKEY}->{$a} = 1; return $a; } # called if we have run out of normal keys # args: $self Returns: undef or "SUBHEADER" sub _check_for_subhdr { my $self = shift; if (scalar(@{ $self->subhdrs}) && !$self->{SEENKEY}->{SUBHEADERS}) { $self->{SEENKEY}->{SUBHEADERS} = 1; return "SUBHEADERS"; } return undef; } # garbage collection # sub DESTROY { } # T I M E A T T H E B A R -------------------------------------------- =head1 SEE ALSO C, C, C, C. =head1 COPYRIGHT Copyright (C) 2007-2011 Science and Technology Facilties Council. Copyright (C) 2001-2007 Particle Physics and Astronomy Research Council and portions Copyright (C) 2002 Southwest Research Institute. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful,but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place,Suite 330, Boston, MA 02111-1307, USA =head1 AUTHORS Alasdair Allan Eaa@astro.ex.ac.ukE, Tim Jenness Et.jenness@jach.hawaii.eduE, Craig DeForest Edeforest@boulder.swri.eduE, Jim Lewis Ejrl@ast.cam.ac.ukE, Brad Cavanagh Eb.cavanagh@jach.hawaii.eduE =cut package Astro::FITS::HeaderCollection; use 5.006; use warnings; use strict; use Carp; our $VERSION; $VERSION = '3.08'; # Class wrapper for subhdrs tie. Not (yet) a public interface # we simply need a class that we can tie the subhdrs array to. sub TIEARRAY { my ($class, $container) = @_; # create an object, but we want to avoid blessing the actual # array into this class return bless { SUBHDRS => $container }, $class; } # must return a new tie sub FETCH { my $self = shift; my $index = shift; my $arr = $self->{SUBHDRS}; if ( $index >= 0 && $index <= $#$arr ) { return $self->_hdr_to_tie( $arr->[$index] ); } else { return undef; } } sub STORE { my $self = shift; my $index = shift; my $value = shift; my $hdr = $self->_tie_to_hdr( $value ); $self->{SUBHDRS}->[$index] = $hdr; } sub FETCHSIZE { my $self = shift; return scalar( @{ $self->{SUBHDRS} }); } sub STORESIZE { croak "Tied STORESIZE for SUBHDRS not yet implemented\n"; } sub EXTEND { } sub EXISTS { my $self = shift; my $index = shift; my $arr = $self->{SUBHDRS}; return 0 if $index > $#$arr || $index < 0; return 1 if defined $self->{SUBHDRS}->[$index]; return 0; } sub DELETE { my $self = shift; my $index = shift; $self->{SUBHDRS}->[$index] = undef; } sub CLEAR { my $self = shift; @{ $self->{SUBHDRS} } = (); } sub PUSH { my $self = shift; my @list = @_; # convert @list = map { $self->_tie_to_hdr($_) } @list; push(@{ $self->{SUBHDRS} }, @list); } sub POP { my $self = shift; my $popped = pop( @{ $self->{SUBHDRS} } ); return $self->_hdr_to_tie($popped); } sub SHIFT { my $self = shift; my $shifted = shift( @{ $self->{SUBHDRS} } ); return $self->_hdr_to_tie($shifted); } sub UNSHIFT { my $self = shift; my @list = @_; # convert @list = map { $self->_tie_to_hdr($_) } @list; unshift(@{ $self->{SUBHDRS} }, @list); } # internal mappings # Given an Astro::FITS::Header object, return the thing that # should be returned to the user of the tie sub _hdr_to_tie { my $self = shift; my $hdr = shift; if (defined $hdr) { my %header; tie %header, ref($hdr), $hdr; return \%header; } return undef; } # convert an input argument as either a Astro::FITS::Header object # or a hash, to an internal representation (an A:F:H object) sub _tie_to_hdr { my $self = shift; my $value = shift; if (UNIVERSAL::isa($value, "Astro::FITS::Header")) { return $value; } elsif (ref($value) eq 'HASH') { my $tied = tied %$value; if (defined $tied && UNIVERSAL::isa($tied, "Astro::FITS::Header")) { # Just take the object return $tied; } else { # Convert it to a hash my @items = map { new Astro::FITS::Header::Item( Keyword => $_, Value => $value->{$_} ) } keys (%{$value}); # Create the Header object. return new Astro::FITS::Header( Cards => \@items ); } } else { croak "Do not know how to store '$value' in a SUBHEADER\n"; } } # L A S T O R D E R S ------------------------------------------------------ 1; Astro-FITS-Header-3.08/lib/Astro/FITS/Header000755004077000012 014014777770 17644 5ustar00gbellstaff000000000000Astro-FITS-Header-3.08/lib/Astro/FITS/Header/AST.pm000444004077000012 750514014777770 20775 0ustar00gbellstaff000000000000package Astro::FITS::Header::AST; =head1 NAME Astro::FITS::Header::AST - Manipulates FITS headers from an AST object =head1 SYNOPSIS use Astro::FITS::Header::AST; $header = new Astro::FITS::Header::AST( FrameSet => $wcsinfo ); $header = new Astro::FITS::Header::AST( FrameSet => $wcsinfo, Encoding => 'FITS-IRAF' ); $header = new Astro::FITS::Header::AST( Cards => \@cards ); =head1 DESCRIPTION This module makes use of the L module to read the FITS HDU from an AST FrameSet object. It stores information about a FITS header block in an object. Takes an hash as an argument, with an array reference pointing to an Starlink::AST FramSet object. =cut # L O A D M O D U L E S -------------------------------------------------- use strict; use vars qw/ $VERSION /; use Astro::FITS::Header::Item; use base qw/ Astro::FITS::Header /; use Carp; require Starlink::AST; $VERSION = 3.08; # C O N S T R U C T O R ---------------------------------------------------- =head1 REVISION $Id$ =head1 METHODS =over 4 =item B Reads a FITS header from a Starlink::AST FrameSet object $header->configure( FrameSet => $wcsinfo ); Base class initialisation also works: $header->configure( Cards => \@cards ); Accepts a reference to an Starlink::AST FrameSet object. If a specific encoding is required, this can be specified using the Encoding argument. Default is FITS-WCS if no Encoding is given. Note that not all framesets can be encoded using FITS-WCS. $header->configure( FrameSet => $wcsinfo, Encoding => "Native" ); If Encoding is specified but undefined, the default will be decided by AST. =cut sub configure { my $self = shift; my %args = @_; # initialise the inherited status to OK. my $status = 0; return $self->SUPER::configure(%args) if exists $args{Cards} or exists $args{Items}; # read the args hash unless (exists $args{FrameSet}) { croak("Arguement hash does not contain FrameSet or Cards"); } my $wcsinfo = $args{FrameSet}; my @cards; { my $fchan = new Starlink::AST::FitsChan( sink => sub { push @cards, $_[0] } ); if (exists $args{Encoding}) { if (defined $args{Encoding}) { # use AST default if undef is supplied $fchan->Set( Encoding => $args{Encoding} ); } } else { # Historical default $fchan->Set( Encoding => "FITS-WCS" ); } $status = $fchan->Write( $wcsinfo ); } return $self->SUPER::configure( Cards => \@cards ); } # shouldn't need to do this, croak! croak! sub writehdr { my $self = shift; croak("Not yet implemented"); } # T I M E A T T H E B A R -------------------------------------------- =back =head1 SEE ALSO C, C =head1 AUTHORS Alasdair Allan Eaa@astro.ex.ac.ukE, Tim Jenness Et.jenness@jach.hawaii.eduE =head1 COPYRIGHT Copyright (C) 2007-2011 Science and Technology Facilities Council. Copyright (C) 2001-2005 Particle Physics and Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful,but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place,Suite 330, Boston, MA 02111-1307, USA =cut # L A S T O R D E R S ------------------------------------------------------ 1; Astro-FITS-Header-3.08/lib/Astro/FITS/Header/CFITSIO.pm000444004077000012 1664014014777770 21466 0ustar00gbellstaff000000000000package Astro::FITS::Header::CFITSIO; # --------------------------------------------------------------------------- =head1 NAME Astro::FITS::Header::CFITSIO - Manipulates FITS headers from a FITS file =head1 SYNOPSIS use Astro::FITS::Header::CFITSIO; $header = new Astro::FITS::Header::CFITSIO( Cards => \@array ); $header = new Astro::FITS::Header::CFITSIO( File => $file ); $header = new Astro::FITS::Header::CFITSIO( fitsID => $ifits ); $header->writehdr( File => $file ); $header->writehdr( fitsID => $ifits ); =head1 DESCRIPTION This module makes use of the L module to read and write directly to a FITS HDU. It stores information about a FITS header block in an object. Takes an hash as an argument, with either an array reference pointing to an array of FITS header cards, or a filename, or (alternatively) and FITS identifier. =cut # L O A D M O D U L E S -------------------------------------------------- use strict; use vars qw/ $VERSION /; use Astro::FITS::Header::Item; use base qw/ Astro::FITS::Header /; use Astro::FITS::CFITSIO qw / :longnames :constants /; use Carp; $VERSION = 3.08; # C O N S T R U C T O R ---------------------------------------------------- =head1 REVISION $Id$ =head1 METHODS =over 4 =item B Reads a FITS header from a FITS HDU $header->configure( Cards => \@cards ); $header->configure( fitsID => $ifits ); $header->configure( File => $file ); $header->configure( File => $file, ReadOnly => $bool ); Accepts an FITS identifier or a filename. If both fitsID and File keys exist, fitsID key takes priority. If C is specified, the file is normally opened in ReadWrite mode. The C argument takes a boolean value which determines whether the file is opened ReadOnly. =cut sub configure { my $self = shift; my %args = ( ReadOnly => 0, @_ ); # itialise the inherited status to OK. my $status = 0; my $ifits; return $self->SUPER::configure(%args) if exists $args{Cards} or exists $args{Items}; # read the args hash if (exists $args{fitsID}) { $ifits = $args{fitsID}; } elsif (exists $args{File}) { $ifits = Astro::FITS::CFITSIO::open_file( $args{File}, $args{ReadOnly} ? Astro::FITS::CFITSIO::READONLY() : Astro::FITS::CFITSIO::READWRITE(), $status ); } else { croak("Arguement hash does not contain fitsID, File or Cards"); } # file sucessfully opened? if( $status == 0 ) { # Get size of FITS header my ($numkeys, $morekeys); $ifits->get_hdrspace( $numkeys, $morekeys, $status); # Set the FITS array to empty my @fits = (); # read the cards. Note that CFITSIO doesn't include the END card # in it's counting for my $i (1 .. $numkeys) { $ifits->read_record($i, my $card, $status); push(@fits, $card); } # add an END card. previously this was extracted from CFITSIO # by reading an extra card. however, the header may not have # been completed by CFITSIO, so that extra card might not exist. push @fits, Astro::FITS::Header::Item->new( Keyword => 'END')->card; if ($status == 0) { # Parse the FITS array $self->SUPER::configure( Cards => \@fits ); } else { # Report bad exit status croak("Error $status reading FITS array"); } # Look at the name of the file as it was passed in. If there is a FITS # extension specified, then this is a single fits image that you want # read. If there isn't one specified, then we should read each of the # extensions that exist in the file, if in fact there are any. if ( exists $args{File} ) { my $ext; fits_parse_extnum($args{File},$ext,$status); my @subfrms = (); if ($ext == -99) { my $nhdus; $ifits->get_num_hdus($nhdus,$status); foreach my $ihdu (1 .. $nhdus-1) { my $subfr = sprintf("%s[%d]",$args{File},$ihdu); my $sself = $self->new(File=>$subfr, ReadOnly => $args{ReadOnly}); push @subfrms,$sself; } } $self->subhdrs(@subfrms); } } # clean up if ( $status != 0 ) { croak("Error $status opening FITS file"); } # close file, but only if we opened it $ifits->close_file( $status ) unless exists $args{fitsID}; return; } # W R I T E H D R ----------------------------------------------------------- =item B Write a FITS header to a FITS file $header->writehdr( File => $file ); $header->writehdr( fitsID => $ifits ); Its accepts a FITS identifier or a filename. If both fitsID and File keys exist, fitsID key takes priority. Returns undef on error, true if the header was written successfully. =cut sub writehdr { my $self = shift; my %args = @_; return $self->SUPER::configure(%args) if exists $args{Cards}; # itialise the inherited status to OK. my $status = 0; my $ifits; # read the args hash if (exists $args{fitsID}) { $ifits = $args{fitsID}; } elsif (exists $args{File}) { $ifits = Astro::FITS::CFITSIO::open_file( $args{File}, Astro::FITS::CFITSIO::READWRITE(), $status ); } else { croak("Argument hash does not contain fitsID, File or Cards"); } # file sucessfully opened? if( $status == 0 ) { # Get size of FITS header my ($numkeys, $morekeys); $ifits->get_hdrspace( $numkeys, $morekeys, $status); # delete the cards in the current header. as cards are deleted the # ones below it are shifted up (according to the CFITSIO docs). # we thus delete from the bottom up to avoid all of that work. $ifits->delete_record( $numkeys--, $status ) while $numkeys; # write the new cards, not including END card if it exists my @cards = $self->cards; if ( defined (my $end_card = $self->index('END')) ) { splice( @cards, $end_card, 1 ) } $ifits->write_record($_, $status ) foreach @cards; } # clean up if ( $status != 0 ) { croak("Error $status opening FITS file"); } # close file, but only if we opened it $ifits->close_file( $status ) unless exists $args{fitsID}; return; } # T I M E A T T H E B A R -------------------------------------------- =back =head1 NOTES This module requires Pete Ratzlaff's L module, and William Pence's C subroutine library (v2.1 or greater). =head1 SEE ALSO L, L, L, L =head1 AUTHORS Alasdair Allan Eaa@astro.ex.ac.ukE, Jim Lewis Ejrl@ast.cam.ac.ukE, Diab Jerius. =head1 COPYRIGHT Copyright (C) 2007-2009 Science & Technology Facilities Council. Copyright (C) 2001-2006 Particle Physics and Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful,but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place,Suite 330, Boston, MA 02111-1307, USA =cut # L A S T O R D E R S ------------------------------------------------------ 1; Astro-FITS-Header-3.08/lib/Astro/FITS/Header/GSD.pm000444004077000012 1076214014777770 21002 0ustar00gbellstaff000000000000package Astro::FITS::Header::GSD; =head1 NAME Astro::FITS::Header::GSD - Manipulate FITS headers from GSD files =head1 SYNOPSIS use Astro::FITS::Header::GSD; $hdr = new Astro::FITS::Header::GSD( Cards => \@cards ); $hdr = new Astro::FITS::Header::GSD( gsdobj => $gsd ); $hdr = new Astro::FITS::Header::GSD( File => $file ); =head1 DESCRIPTION This module makes use of the Starlink L module to read from a GSD header. It stores information about a FITS header block in an object. Takes an hash as an argument, with either an array reference pointing to an array of FITS header cards, or a filename, or (alternatively) a GSD object. =cut use strict; use Carp; use GSD; use Astro::FITS::Header::Item; use base qw/ Astro::FITS::Header /; use vars qw/ $VERSION /; $VERSION = 3.08; =head1 METHODS =over 4 =item B Reads a header from a GSD file. $hdr->configure( Cards => \@cards ); $hdr->configure( Items => \@items ); $hdr->configure( gsdobj => $gsd ); $hdr->configure( File => $filename ); Accepts a GSD object or a filename. If both C and C keys exist, C key takes priority. =cut sub configure { my $self = shift; my %args = @_; my ($indf, $started); my $task = ref($self); return $self->SUPER::configure(%args) if exists $args{Cards} or exists $args{Items}; my $gsd; if (exists $args{gsdobj} && defined $args{gsdobj}) { $gsd = $args{gsdobj}; croak "gsd object must be of class 'GSD'" unless UNIVERSAL::isa($gsd, 'GSD'); } elsif (exists $args{File}) { # Open the file $gsd = new GSD( $args{File} ); croak "Error opening gsd file $args{File}" unless defined $gsd; } else { croak "Argument hash does not contain gsdobj, File or Cards!"; } # Somewhere to store the FITS information my @cards; # Read through all the items extracting the scalar items for my $i (1..$gsd->nitems) { my ($name, $units, $type, $array) = $gsd->Item( $i ); if (!$array) { # Only scalars my $value = $gsd->GetByNum( $i ); # Generate a comment string my $comment = ''; $comment .= "[$units]" if $units; if (length($name) > 8 ) { $comment .= " Name shortened from $name"; $name = substr($name, 0, 8); } # We need to convert the type from GSD to one that's a FITS # type. if( ( $type eq 'R' ) || ( $type eq 'D' ) ) { $type = "FLOAT"; } elsif( ( $type eq 'I' ) || ( $type eq 'W' ) || ( $type eq 'B' ) ) { $type = "INT"; } elsif( $type eq 'C' ) { $type = "STRING"; } elsif( $type eq 'L' ) { $type = "LOGICAL"; } # We do not have an actual FITS style string so we just # create the item directly push(@cards, new Astro::FITS::Header::Item( Keyword => $name, Comment => $comment, Value => $value, Type => $type, )); } } # Configure the object $self->SUPER::configure( Items => \@cards ); return; } =item B The GSD library is read-only. The writehdr method is not implemented for this sub-class. =cut sub writehdr { croak "The GSD library is read-only. The writehdr method is not implemented for this sub-class."; } =back =head1 NOTES This module requires the Starlink L module. GSD supports keys that are longer than the 8 characters allowed as part of the FITS standard. GSD keys are truncated to 8 characters by this module. =head1 SEE ALSO L, L, L L, L =head1 AUTHORS Tim Jenness Et.jenness@jach.hawaii.eduE, Alasdair Allan Eaa@astro.ex.ac.ukE =head1 COPYRIGHT Copyright (C) 2008-2011 Science & Technology Facilities Council. Copyright (C) 2001-2002 Particle Physics and Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful,but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place,Suite 330, Boston, MA 02111-1307, USA =cut 1; Astro-FITS-Header-3.08/lib/Astro/FITS/Header/Item.pm000444004077000012 5350214014777770 21262 0ustar00gbellstaff000000000000package Astro::FITS::Header::Item; =head1 NAME Astro::FITS::Header::Item - A card image from a FITS header =head1 SYNOPSIS $item = new Astro::FITS::Header::Item( Card => $card ); $item = new Astro::FITS::Header::Item( Keyword => $keyword, Value => $value, Comment => $comment, Type => 'int' ); $value = $item->value(); $comment = $item->comment(); $card = $item->card(); $card = "$item"; =head1 DESCRIPTION Stores information about a FITS header item (in the FITS standard these are called B). FITS Card Images can be parsed and broken into their component keyword, values and comments. Card Images can also be created from its components keyword, value and comment. =cut use strict; use overload ( '""' => 'overload_kluge' ); use vars qw/ $VERSION /; use Carp; $VERSION = 3.08; =head1 METHODS =head2 Constructor =over 4 =item B Create a new instance. Optionally can be given a hash containing information from a header item or the card image itself. $item = new Astro::FITS::Header::Item( Card => $card ); $item = new Astro::FITS::Header::Item( Keyword => $keyword, Value => $value ); The list of allowed hash keys is documented in the B method. Returns C if the information supplied was insufficient to generate a valid header item. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $item = { Keyword => undef, Comment => undef, Value => undef, Type => undef, Card => undef, # a cache }; bless $item, $class; # If we have arguments configure the object $item->configure( @_ ) if @_; return $item; } =item B Make a copy of an Astro::FITS::Header::Item object. $newitem = $item->copy; =cut sub copy { my $self = shift; my %copy = %$self; return bless \%copy, ref( $self ); } =back =head2 Accessor Methods =over 4 =item B Return (or set) the value of the keyword associated with the FITS card. $keyword = $item->keyword(); $item->keyword( $key ); When a new value is supplied any C in the cache is invalidated. Supplied value is always upper-cased. =cut sub keyword { my $self = shift; if (@_) { $self->{Keyword} = uc(shift); $self->{Card} = undef; } return $self->{Keyword}; } =item B Return (or set) the value of the value associated with the FITS card. $value = $item->value(); $item->value( $val ); When a new value is supplied any C in the cache is invalidated. If the value is an C object, the type is automatically set to "HEADER". =cut sub value { my $self = shift; if (@_) { my $value = shift; $self->{Value} = $value; $self->{Card} = undef; if (UNIVERSAL::isa($value,"Astro::FITS::Header" )) { $self->type( "HEADER" ); } elsif (defined $self->type && $self->type eq 'HEADER') { # HEADER is only valid if we really are a HEADER $self->type(undef); } } return $self->{Value}; } =item B Return (or set) the value of the comment associated with the FITS card. $comment = $item->comment(); $item->comment( $comment ); When a new value is supplied any C in the cache is invalidated. =cut sub comment { my $self = shift; if (@_) { $self->{Comment} = shift; $self->{Card} = undef; } return $self->{Comment}; } =item B Return (or set) the value of the variable type associated with the FITS card. $type = $item->type(); $item->type( "INT" ); Allowed types are "LOGICAL", "INT", "FLOAT", "STRING", "COMMENT", "HEADER" and "UNDEF". The special type, "HEADER", is used to specify that this item refers to a subsidiary header (eg a header in an MEFITS file or a header in an NDF in an HDS container). See also the C method in C for an alternative way of specifying a sub-header. The type is case-insensitive, but will always be returned up-cased. =cut sub type { my $self = shift; if (@_) { my $type = shift; $type = uc($type) if defined $type; $self->{Type} = $type; } return $self->{Type}; } =item B Return (or set) the 80 character header card associated with this object. It is created if there is no cached version. $card = $item->card(); If a new card is supplied it will only be accepted if it is 80 characters long or fewer. The string is padded with spaces if it is too short. No attempt (yet) )is made to shorten the string if it is too long since that may require a check to see if the value is a string that must be shortened with a closing single quote. Returns C on assignment failure (else returns the supplied string). $status = $item->card( $card ); C is returned if there is insufficient information in the object to create a new card. Can assign C to clear the cache. This method is called automatically when attempting to stringify the object. $card = "$item"; =cut # This is required because overloaded methods are called with # extra arguments and card() can not tell the difference between # an undef value and a stringify request sub overload_kluge { my $self = shift; return $self->card; } sub card { my $self = shift; if (@_) { my $card = shift; if (defined $card) { my $clen = length($card); # force to 80 characters if ($clen < 80) { $card = $card . (" "x(80-$clen)); } elsif ($clen > 80) { $card = substr($card, 0, 80); } } # can assign undef to clear $self->{Card} = $card; } # We are returning a value. Create if not present # Since we are being called by stringify to set the object # we need to make sure we don't get into an endless loop # trying to create the string but not having the correct info # Especially important since stringify calls card(). $self->{Card} = $self->_stringify unless defined $self->{Card}; return $self->{Card}; } =back =head2 General Methods =over 4 =item B Configures the object from multiple pieces of information. $item->configure( %options ); Takes a hash as argument with the following keywords: =over 8 =item B If supplied, the value is assumed to be a standard 80 character FITS header card. This is sent to the C method directly. Takes priority over any other key. If it is an C it will be copied rather than parsed. =item B Used to specify the keyword associated with this object. =item B Used to specify the value associated with this FITS item. =item B Used to specify the comment associated with this FITS item. =item B Used to specify the variable type. See the C method for more details. A type will be guessed if one is not supplied. The guess may well be wrong. =back Does nothing if these keys are not supplied. =cut sub configure { my $self = shift; my %hash = @_; if (exists $hash{'Card'}) { if (ref($hash{Card}) && $hash{Card}->isa("Astro::FITS::Header::Item")) { # low level populate - can not use copy since we already have a copy for my $k (keys %{$hash{Card}}) { $self->{$k} = $hash{Card}->{$k}; } } else { $self->parse_card( $hash{'Card'}); } } else { # Loop over the allowed keys storing the values # in the object if they exist for my $key (qw/Keyword Type Comment Value/) { my $method = lc($key); $self->$method( $hash{$key}) if exists $hash{$key}; } # only set type if we have not been given a type if (!$self->type) { if (!$self->keyword && !$self->value) { # completely blank $self->type("BLANK"); } elsif (!$self->keyword || $self->keyword =~ /^(COMMENT|HISTORY)$/) { # COMMENT, HISTORY, and blank cards are special $self->type('COMMENT') } else { my $type = $self->guess_type( $self->value ); $self->type( $type ) if defined $type; } } # End cards are special, need only do a Keyword => 'END' to configure $self->type('END') if $self->keyword() eq 'END'; } } =item B Method to return a blessed reference to the object so that we can store ths object on disk using Data::Dumper module. =cut sub freeze { my $self = shift; return bless $self, 'Astro::FITS::Header::Item'; } =item B Parse a FITS card image and store the keyword, value and comment into the object. ($key, $val, $com) = $item->parse_card( $card ); Returns an empty list on error. =cut # Fits standard specifies # Characters 1:8 KEYWORD (trailing spaces) Comment cards: COMMENT, # HISTORY, blank, and HIERARCH are special. # 9:10 "= " for a valid value (unless comment keyword) # 11:80 The Value "/" used to indicate a comment # HIERARCH keywords # This is a comment but used to store values in an extended, # hierarchical name space. The keyword is the string before # the equals sign and ignoring trailing spaces. The value # follows the first equals sign. The comment is delimited by a # solidus following a string or a single value. The HIERARCH # keyword may follow a blank keyword in columns 1:8.. # # The value can contain: # STRINGS: # ' starting at position 12 # A single quote represented as '' # Closing quote must be at position 20 or greater (max 80) # Trailing blanks are removed. Leading spaces in the quotes # are significant # LOGICAL # T or F in column 30. Translated to 1 or 0 # Numbers # D is an allowed exponent as well as E sub parse_card { my $self = shift; return () unless @_; my $card = shift; my $equals_col = 8; # Remove new line and pad card to 80 characters chomp($card); # $card = sprintf("%-80s", $card); # Value is only present if an = is found in position 9 my ($value, $comment) = ('', ''); my $keyword = uc(substr($card, 0, $equals_col)); # HIERARCH special case. It's a comment, but want to treat it as # a multi-word keyword followed by a value and/or comment. if ( $keyword eq 'HIERARCH' || $card =~ /^\s+HIERARCH/ ) { $equals_col = index( $card, "=" ); $keyword = uc(substr($card, 0, $equals_col )); } # Remove leading and trailing spaces, and replace interior spaces # between the keywords with a single . $keyword =~ s/^\s+// if ( $card =~ /^\s+HIERARCH/ ); $keyword =~ s/\s+$//; $keyword =~ s/\s+/./g; # update object $self->keyword( $keyword ); # END cards are special if ($keyword eq 'END') { $self->comment(undef); $self->value(undef); $self->type( "END" ); $self->card( $card ); # store it after storing indiv components return("END", undef, undef); } # This will be a blank line but will not trigger here if we # are padding to 80 characters if (length($card) == 0) { $self->type( "BLANK" ); return( undef, undef, undef); } # Check for comment or HISTORY # If the card is not padded this may trigger a warning on the # substr going out of bounds if ($keyword eq 'COMMENT' || $keyword eq 'HISTORY' || (substr($card,8,2) ne "= " && $keyword !~ /^HIERARCH/)) { # Store the type $self->type( "COMMENT" ); # We have comments unless ( length( $card) <= 8 ) { $comment = substr($card,8); $comment =~ s/\s+$//; # Trailing spaces } else { $comment = ""; } # Alasdair wanted to store this as a value $self->comment( $comment ); $self->card( $card ); # store it after storing indiv components return ($keyword, undef, $comment); } # We must have a value after '= ' my $rest = substr($card, $equals_col+1); # Remove leading spaces $rest =~ s/^\s+//; # Check to see if we have a string if (substr($rest,0,1) eq "'") { $self->type( "STRING" ); # Check for empty (null) string '' if (substr($rest,1,1) eq "'") { $value = ''; $comment = substr($rest,2); $comment =~ s/^\s+\///; # Delete everything before the first slash } else { # '' needs to be treated as an escaped ' when inside the string # Use index to search for an isolated single quote my $pos = 1; my $end = -1; while ($pos = index $rest, "'", $pos) { last if $pos == -1; # could not find a close quote # Check for the position after this and if it is a ' # increment and loop again if (substr($rest, $pos+1, 1) eq "'") { $pos += 2; # Skip past next one next; } # Isolated ' so this is the end of the string $end = $pos; last; } # At this point we should have the end of the string or the # position of the last quote if ($end != -1) { # Value $value = substr($rest,1, $pos-1); # Replace '' with ' $value =~ s/''/'/; #; ' # Special case a blank string if ($value =~ /^\s+$/) { $value = " "; } else { # Trim $value =~ s/\s+$//; } # Comment $comment = substr($rest,$pos+1); # Extract post string $comment =~ s/^\s+\///; # Delete everything before the first slash $comment =~ s/\///; # In case there was no space before the slash } else { # Never found the end so include all of it $value = substr($rest,1); # Trim $value =~ s/\s+$//; $comment = ''; } } } else { # Non string - simply read the first thing before a slash my $pos = index($rest, "/"); if ($pos == 0) { # No value at all $value = undef; $comment = substr($rest, $pos+2); $self->type("UNDEF"); } elsif ($pos != -1) { # Found value and comment $value = substr($rest, 0, $pos); $value =~ s/\s+$//; # remove any gap to the comment # Check for case where / is last character if (length($rest) > ($pos + 1)) { $comment = substr($rest, $pos+2); $comment =~ s/\s+$//; } else { $comment = undef; } } else { # Only found a value $value = $rest; $comment = undef; } if (defined $value) { # Replace D or E with and e - D is not allowed as an exponent in perl $value =~ tr/DE/ee/; # Need to work out the numeric type if ($value eq 'T') { $value = 1; $self->type('LOGICAL'); } elsif ($value eq 'F') { $value = 0; $self->type('LOGICAL'); } elsif ($value =~ /\.|e/) { # float $self->type("FLOAT"); } else { $self->type("INT"); } # Remove trailing spaces $value =~ s/\s+$//; } } # Tidy up comment if (defined $comment) { if ($comment =~ /^\s+$/) { $comment = ' '; } else { # Trim it $comment =~ s/\s+$//; $comment =~ s/^\s+//; } } # Store in the object $self->value( $value ); $self->comment( $comment ); # Store the original card # Must be done after storing val, comm etc $self->card( $card ); # Value is allowed to be '' return($keyword, $value, $comment); } =item B Compares this Item with another and returns true if the keyword, value, type and comment are all equal. $isident = $item->equals( $item2 ); =cut sub equals { my $self = shift; my $ref = shift; # Loop over the string keywords for my $method (qw/ keyword type comment /) { my $val1 = $self->$method; my $val2 = $ref->$method; if (defined $val1 && defined $val2) { # These are all string comparisons if ($val1 ne $val2) { return 0; } } elsif (!defined $val1 && !defined $val2) { # both undef so equal } else { # one undef, the other defined return 0; } } # value comparison will depend on type # we know the types are the same my $val1 = $self->value; my $val2 = $ref->value; my $type = $self->type; return 0 if ((defined $val1 && !defined $val2) || (defined $val2 && !defined $val1)); return 1 if (!defined $val1 && !defined $val2); if ($type eq 'FLOAT' || $type eq 'INT') { return ( $val1 == $val2 ); } elsif ($type eq 'STRING') { return ( $val1 eq $val2 ); } elsif ($type eq 'LOGICAL') { if (($val1 && $val2) || (!$val1 && !$val2)) { return 1; } else { return 0; } } elsif ($type eq 'COMMENT') { # if we get to here we have a defined value so we should # check it even if COMMENT is meant to use COMMENT return ($val1 eq $val2); } elsif ($type eq 'HEADER') { my @items1 = $val1->allitems; my @items2 = $val2->allitems; # count the items return 0 if @items1 != @items2; for my $i (0..$#items1) { return 0 if ! $items1[$i]->equals( $items2[$i] ); } return 1; } elsif ($type eq 'UNDEF') { # both are undef... return 1; } else { croak "Unable to compare items of type '$type'\n"; } # somehow we got to the end return 0; } =begin __private =item B<_stringify> Internal routine to generate a FITS header card using the contents of the object. This rouinte should not be called directly. Use the C method to retrieve the contents. $card = $item->_stringify; The object state is not updated by this routine. This routine is only called if the card cache has been cleared. If this item points to a sub-header the stringification returns a comment indicating that we have a sub header. In the future this behaviour may change (either to return nothing, or to return the stringified header itself). =cut sub _stringify { my $self = shift; # Get the components my $keyword = $self->keyword; my $value = $self->value; my $comment = $self->comment; my $type = $self->type; # Special case for HEADER type if (defined $type && $type eq 'HEADER') { $type = "COMMENT"; $comment = "Contains a subsidiary header"; } # Sort out the keyword. This always uses up the first 8 characters my $card = sprintf("%-8s", $keyword); # End card and Comments first if (defined $type && $type eq 'END' ) { $card = sprintf("%-10s%-70s", $card, ""); } elsif (defined $type && $type eq 'BLANK') { $card = " " x 80; } elsif (defined $type && $type eq 'COMMENT') { # Comments are from character 9 - 80 $card = sprintf("%-8s%-72s", $card, (defined $comment ? $comment : '')); } elsif (!defined $type && !defined $value && !defined $comment) { # This is a blank line $card = " " x 80; } else { # A real keyword/value so add the "= " $card .= "= "; # Try to sort out the type if we havent got one # We can not find LOGICAL this way since we can't # tell the difference between 'F' and F # an undefined value is typeless unless (defined $type) { $type = $self->guess_type( $value ); } # Numbers behave identically whether they are float or int # Logical is a number formatted as a "T" or "F" if ($type eq 'INT' or $type eq 'FLOAT' or $type eq 'LOGICAL' or $type eq 'UNDEF') { # Change the value for logical if ($type eq 'LOGICAL') { $value = ( ($value && ($value ne 'F')) ? 'T' : 'F' ); } # An undefined value should simply propogate as an empty $value = '' unless defined $value; # A number can only be up to 67 characters long but # Should we raise an error if it is longer? We should # not truncate $value = substr($value,0,67); $value = (' 'x(20-length($value))).$value; # Translate lower case e to upper # Probably should test length of exponent to decide # whether we should be using D instead of E # [depends whether the argument is stringified or not] $value =~ tr /ed/ED/; } elsif ($type eq 'STRING') { # Check that a value is there # There is a distinction between '''' and nothing '' if (defined $value) { # Escape single quotes $value =~ s/'/''/g; #'; # chop to 65 characters $value = substr($value,0, 65); # if the string has less than 8 characters pad it to put the # closing quote at CHAR 20 if (length($value) < 8 ) { $value = $value.(' 'x(8-length($value))) unless length($value) == 0; } $value = "'$value'"; } else { $value = ''; # undef is an empty FITS string } # Pad goes reverse way to a number $value = $value.(' 'x(20-length($value))); } else { carp("Type '$type' is not a recognized type. Header creation may be incorrect"); } # Add the comment if (defined $comment && length($comment) > 0) { $card .= $value . ' / ' . $comment; } else { $card .= $value; } # Fix at 80 characters $card = substr($card,0,80); $card .= ' 'x(80-length($card)); } # Return the result return $card; } =item B This class method can be used to guess the data type of a supplied value. It is private but can be used by other classes in the Astro::FITS::Header hierarchy. $type = Astro::FITS::Header::Item->guess_type( $value ); Can not distinguish a string F from a LOGICAL F so will always guess "string". Returns "string" if a type could not be determined. =cut sub guess_type { my $self = shift; my $value = shift; my $type; if (!defined $value) { $type = "UNDEF"; } elsif ($value =~ /^\d+$/) { $type = "INT"; } elsif ($value =~ /^(-?)(\d*)(\.?)(\d*)([EeDd][-\+]?\d+)?$/) { $type = "FLOAT"; } else { $type = "STRING"; } return $type; } =end __private =back =head1 SEE ALSO C =head1 COPYRIGHT Copyright (C) 2008-2009 Science and Technology Facilities Council. Copyright (C) 2001-2007 Particle Physics and Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful,but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place,Suite 330, Boston, MA 02111-1307, USA =head1 AUTHORS Tim Jenness Et.jenness@jach.hawaii.eduE, Alasdair Allan Eaa@astro.ex.ac.ukE =cut 1; Astro-FITS-Header-3.08/lib/Astro/FITS/Header/NDF.pm000444004077000012 2707214014777770 20776 0ustar00gbellstaff000000000000package Astro::FITS::Header::NDF; =head1 NAME Astro::FITS::Header::NDF - Manipulate FITS headers from NDF files =head1 SYNOPSIS use Astro::FITS::Header::NDF; $hdr = new Astro::FITS::Header::NDF( Cards => \@cards ); $hdr = new Astro::FITS::Header::NDF( Items => \@items ); $hdr = new Astro::FITS::Header::NDF( ndfID => $indf ); $hdr = new Astro::FITS::Header::NDF( File => $file ); $hdr->writehdr( $indf ); $hdr->writehdr( File => $file ); =head1 DESCRIPTION This module makes use of the Starlink L module to read and write to an NDF FITS extension or to a C<.HEADER> block in an HDS container file. If the file is found to be an HDS container containing multiple NDFs at the top level, either the .HEADER NDF or the first NDF containing a FITS header is deemed to be the primary header, and all other headers a subsidiary headers indexed by the name of the NDF in the container. It stores information about a FITS header block in an object. Takes an hash as an argument, with either an array reference pointing to an array of FITS header cards, array of C objects, or a filename, or (alternatively) an NDF identifier. Currently, subheader support is readonly. =cut use strict; use Carp; use File::Spec; use NDF qw/ :ndf :dat :err :hds :msg /; use base qw/ Astro::FITS::Header /; use vars qw/ $VERSION /; $VERSION = 3.08; =head1 METHODS =over 4 =item B Reads a FITS header from an NDF. $hdr->configure( Cards => \@cards ); $hdr->configure( ndfID => $indf ); $hdr->configure( File => $filename ); Accepts an NDF identifier or a filename. If both C and C keys exist, C key takes priority. If the file is actually an HDS container, an attempt will be made to read a ".HEADER" NDF inside that container (this is the standard layout of UKIRT (and some JCMT) data files). If an extension is specified explicitly (that is not ".sdf") that path is treated as an explicit path to an NDF. If an explicit path is specified no attempt is made to locate other NDFs in the HDS container. If the NDF can be opened successfully but there is no .MORE.FITS extension, an empty header is returned rather than throwing an error. =cut sub configure { my $self = shift; my %args = @_; my ($indf, $started); my $task = ref($self); return $self->SUPER::configure(%args) if exists $args{Cards} or exists $args{Items}; # Store the definition of good locally my $status = &NDF::SAI__OK; my $good = $status; # Start error system (this may be the first time we hit # starlink) err_begin( $status ); # did we start NDF my $ndfstarted; my $FileName = ""; # Read the args hash if (exists $args{ndfID}) { $indf = $args{ndfID}; # Need to work out the file name ndf_msg( "NDF", $indf ); msg_load( " ", "^NDF", $FileName, my $len, $status ); } elsif (exists $args{File}) { # Remove trailing .sdf my $file = $args{File}; $FileName = $file; $file =~ s/\.sdf$//; # NDF currently (c.2008) has troubles with spaces in paths # we work around this by changing to the directory before # opening the file my ($vol, $dir, $root) = File::Spec->splitpath( $file ); my $cwd; if ($dir =~ /\s/) { # only bother if there is a space $cwd = File::Spec->rel2abs( File::Spec->curdir ); # if the chdir fails we will try to open the file # with NDF anyway using the path. Otherwise we change the # filename to be the root if (chdir($dir)) { $file = $root; } } # Start NDF ndf_begin(); $ndfstarted = 1; # First we need to find whether we have an HDS container or a # straight NDF. Rather than simply trying an ndf_find on both # (which causes leaks in the NDF system circa 2001) we explicitly # open it using HDS unless it has a "." in it. if ($file =~ /\./) { # an NDF ndf_find(&NDF::DAT__ROOT(), $file, $indf, $status); } else { # Try HDS hds_open( $file, 'READ', my $hdsloc, $status); # Find its type dat_type( $hdsloc, my $type, $status); if ($status == $good) { # If we have an NDF we can simply reopen it # Additionally if we have no description of the component # at all we assume NDF. This overcomes a bug in the acquisition # for SCUBA where a blank type field is used. my $ndffile; if ($type =~ /NDF/i || $type !~ /\w/) { $ndffile = $file; } else { # For now simply assume we can find a .HEADER # in future we could tweak this to default to first NDF # it finds if no .HEADER $ndffile = $file . ".HEADER"; $FileName .= ".HEADER"; } # Close the HDS file dat_annul( $hdsloc, $status); # Open the NDF ndf_find(&NDF::DAT__ROOT(), $ndffile, $indf, $status); # reset the directory if (defined $cwd) { chdir($cwd) or carp "Could not return to current working directory"; } } } } else { $status = &NDF::SAI__ERROR; err_rep(' ', "$task: Argument hash does not contain ndfID, File or Cards", $status); } if ($status == $good) { # See if the extension exists ndf_xstat( $indf, "FITS", my $there, $status); if ($status == $good && $there) { # Find the FITS extension ndf_xloc($indf, 'FITS', 'READ', my $xloc, $status); if ($status == $good) { # Variables... my (@dim, $ndim, $nfits, $maxdim); # Get the dimensions of the FITS array # Should only be one-dimensional $maxdim = 7; dat_shape($xloc, $maxdim, @dim, $ndim, $status); if ($status == $good) { if ($ndim != 1) { $status = &SAI__ERROR; err_rep(' ',"$task: Dimensionality of FITS array should be 1 but is $ndim", $status); } } # Set the FITS array to empty my @fits = (); # Note that @fits only exists in this block # Read the FITS extension dat_get1c($xloc, $dim[0], @fits, $nfits, $status); # Annul the locator dat_annul($xloc, $status); # Check status and read into hash if ($status == $good) { # Parse the FITS array $self->SUPER::configure( Cards => \@fits ); } else { err_rep(' ',"$task: Error reading FITS array", $status); } } else { # Add my own message to status err_rep(' ', "$task: Error locating FITS extension", $status); } } elsif ($status != $good) { err_rep(' ', "$task: Error determining presence of FITS extension", $status); } else { # simply is not there but file is okay } # Close the NDF identifier (if we opened it) ndf_annul($indf, $status) if exists $args{File}; } # Shutdown ndf_end($status) if $ndfstarted; # Handle errors if ($status != $good) { my ( $oplen, @errs ); do { err_load( my $param, my $parlen, my $opstr, $oplen, $status ); push @errs, $opstr; } until ( $oplen == 1 ); err_annul($status); err_end( $status ); croak "Error during header read from NDF $FileName:\n" . join "\n", @errs; } err_end($status); # It is possible to annul the errors before exiting if we want # or to flush them out. return; } =item B Write a FITS header to an NDF. $hdr->writehdr( ndfID => $indf ); $hdr->writehdr( File => $file ); Accepts an NDF identifier or a filename. If both C and C keys exist, C key takes priority. Throws an exception (croaks) on error. =cut sub writehdr { my $self = shift; my %args = @_; # Store the definition of good locally my $status = &NDF::SAI__OK; my $good = $status; # Start error system (this may be the first time we hit # starlink) err_begin( $status ); # Indicate whether we have started an NDF context or not my $ndfstarted; # Look in the args hash and open the output file if needed my $ndfid; if (exists $args{ndfID}) { $ndfid = $args{ndfID}; } elsif (exists $args{File}) { my $file = $args{File}; $file =~ s/\.sdf//; # Start NDF ndf_begin(); $ndfstarted = 1; ndf_open(&NDF::DAT__ROOT(), $file, 'UPDATE', 'UNKNOWN', $ndfid, my $place, $status); # If status is bad, try assuming it is a HDS container # with UKIRT style .HEADER component if ($status != $good or $ndfid == 0) { # dont want to contaminate existing status my $lstat = $good; my $hdsfile = $file . ".HEADER"; my $useheader; err_mark(); ndf_open(&NDF::DAT__ROOT(), $hdsfile, 'UPDATE', 'UNKNOWN', $ndfid, $place, $lstat); if ($lstat != $good) { err_annul( $lstat ); } else { $useheader = 1; } err_rlse(); # flush bad global status if we succeeded err_annul($status) if $useheader; } # KLUGE : need to get NDF__NOID from the NDF module at some point if ($ndfid == 0 && $status == $good) { # could create it :-) $status = &NDF::SAI__ERROR; err_rep(' ',"File '$file' does not exist to receive the header", $status); } } else { err_end( $status ); croak "Missing argument to writehdr. Must include either ndfID or File key"; } # Now need to find out whether we have a FITS header in the # file already ndf_xstat( $ndfid, 'FITS', my $there, $status); # delete it ndf_xdel($ndfid, 'FITS', $status) if $there; # Get the fits array my @cards = $self->cards; # Write the FITS extension if ($#cards > -1) { # Write it out my @fitsdim = (scalar(@cards)); ndf_xnew($ndfid, 'FITS', '_CHAR*80', 1, @fitsdim, my $fitsloc, $status); dat_put1c($fitsloc, scalar(@cards), @cards, $status); dat_annul($fitsloc, $status); } # Write HISTORY information my @text =("Astro::FITS::Header::NDF - write FITS header to file ^FILE",); ndf_msg( "FILE", $ndfid ); ndf_hput("NORMAL", '', 0, scalar(@text), @text, 1, 1,1, $ndfid, $status ); ndf_annul( $ndfid, $status ); # Shutdown ndf_end($status) if $ndfstarted; # Handle errors if ($status != $good) { my @errs; my $oplen; do { err_load( my $param, my $parlen, my $opstr, $oplen, $status ); push @errs, $opstr; } until ( $oplen == 1 ); err_annul($status); err_end($status); croak "Error during header write to NDF:\n" . join "\n", @errs; } err_end($status); return; } =back =head1 NOTES This module requires the Starlink L module. =head1 SEE ALSO L, L, L L =head1 AUTHORS Tim Jenness Et.jenness@jach.hawaii.eduE, Alasdair Allan Eaa@astro.ex.ac.ukE, Brad Cavanagh Eb.cavanagh@jach.hawaii.eduE =head1 COPYRIGHT Copyright (C) 2008-2009 Science & Technology Facilities Council. Copyright (C) 2001-2005 Particle Physics and Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful,but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place,Suite 330, Boston, MA 02111-1307, USA =cut 1; Astro-FITS-Header-3.08/t000755004077000012 014014777770 14314 5ustar00gbellstaff000000000000Astro-FITS-Header-3.08/t/1_compile.t000444004077000012 517214014777770 16513 0ustar00gbellstaff000000000000#!perl # This test simply loads all the modules # it does this by scanning the directory for .pm files # and use'ing each in turn # It is slow because of the fork required for each separate use use 5.006; use strict; use warnings; # Test module only used for planning # Note that we can not use Test::More since Test::More # will lose count of its tests and complain (through the fork) use Test::More; use File::Find; our @modules; # If SKIP_COMPILE_TEST environment variable is set we # just skip this test because it takes a long time if (exists $ENV{SKIP_COMPILE_TEST}) { print "1..0 # Skip compile tests not required\n"; exit; } # Scan the blib/ directory looking for modules find({ wanted => \&wanted, no_chdir => 1, }, "blib"); # Start the tests plan tests => (scalar(@modules)); # Loop through each module and try to run it $| = 1; my $counter = 0; my $tempfile = "results.dat"; for my $module (@modules) { # Try forking. Perl test suite runs # we have to fork because each "use" will contaminate the # symbol table and we want to start with a clean slate. my $pid; if ($pid = fork) { # parent # wait for the forked process to complete waitpid($pid, 0); # Control now back with parent. } else { # Child die "cannot fork: $!" unless defined $pid; my $isok = 1; my $skip = ''; eval "use $module ();"; if( $@ ) { if ($@ =~ /Can't locate (.*\.pm) in/) { my $missing = $1; diag( "$module can not locate $missing" ); $skip = "missing module $missing from $module"; } else { diag( "require failed with '$@'\n" ); $isok = 0; } } # Open the temp file open( my $fh, "> $tempfile") || die "Could not open $tempfile: $!"; print $fh "$isok $skip\n"; close($fh); exit; } if (open( my $fh, "< $tempfile")) { my $line = <$fh>; close($fh); if (defined $line) { chomp($line); my ($status, $skip) = split(/\s+/, $line, 2); SKIP: { skip( $skip, 1) if $skip; ok( $status, "Load $module"); } } else { ok( 0, "Could not get results from loading module $module"); } } else { # did not get the temp file ok(0, "Could not get results from loading module $module"); } unlink($tempfile); } # This determines whether we are interested in the module # and then stores it in the array @modules sub wanted { my $pm = $_; # is it a module return unless $pm =~ /\.pm$/; # Remove the blib/lib (assumes unix!) $pm =~ s|^blib/lib/||; # Translate / to :: $pm =~ s|/|::|g; # Remove .pm $pm =~ s/\.pm$//; push(@modules, $pm); } Astro-FITS-Header-3.08/t/ast.t000444004077000012 1203414014777770 15445 0ustar00gbellstaff000000000000#!perl # Testing AST dependancies use strict; use Test::More; BEGIN { eval "use Starlink::AST;"; if ($@) { plan skip_all => "Starlink::AST not available."; exit; } else { plan tests => 51; } } # load modules require_ok( "Astro::FITS::Header" ); require_ok( "Astro::FITS::Header::AST" ); require_ok( "Astro::FITS::Header::Item" ); # T E S T H A R N E S S -------------------------------------------------- # GET_WCS() in ASTRO::FITS::HEADER # -------------------------------- # read header from DATA block my @raw = ; chomp(@raw); # build header array my $header = new Astro::FITS::Header( Cards => \@raw ); # test the header for my $i (0 .. $#raw) { my $card = $header->item($i); ok( "$card", $raw[$i]); } # grab the WCS my $wcsinfo = $header->get_wcs(); isa_ok( $wcsinfo, "Starlink::AST::FrameSet" ); # Mappings # -------- # define some arrays (and references) to hold out inital coordinates my ( @x, @y ); my $xpixel = \@x; my $ypixel = \@y; # FORWARD MAPPING $x[0] = 0; $y[0] = 0;; $x[1] = 114; $y[1] = 128; my ( $xworld, $yworld) = $wcsinfo->Tran2( $xpixel, $ypixel, 1 ); is( $$xworld[0], 4.5, "Forward mapping of lower bound X co-ordinate" ); is( $$yworld[0], -0.5, "Forward mapping of lower bound Y co-ordinate" ); is( $$xworld[1], 118.5, "Forward mapping of upper bound X co-ordinate" ); is( $$yworld[1], 127.5, "Forward mapping of upper bound Y co-ordinate" ); # REVERSE MAPPING $x[0] = 4.5; $y[0] = -0.5; $x[1] = 118.5; $y[1] = 127.5; ($xworld, $yworld) = $wcsinfo->Tran2( $xpixel, $ypixel, 0 ); is( $$xworld[0], 0, "Reverse mapping of lower bound X co-ordinate" ); is( $$yworld[0], 0, "Reverse mapping of lower bound Y co-ordinate" ); is( $$xworld[1], 114, "Reverse mapping of upper bound X co-ordinate" ); is( $$yworld[1], 128, "Reverse mapping of upper bound Y co-ordinate" ); # new ASTRO::FITS::HEADER::AST() # ------------------------------ my $ast_header = new Astro::FITS::Header::AST( FrameSet => $wcsinfo ); # test the header is( $ast_header->sizeof(), 9, "Size of returned header" ); exit; __DATA__ SIMPLE = T / file does conform to FITS standard BITPIX = -32 / number of bits per data pixel NAXIS = 2 / number of data axes NAXIS1 = 114 / length of data axis 1 NAXIS2 = 128 / length of data axis 2 CRPIX1 = 57.0 / Reference pixel on axis 1 CRPIX2 = 64.0 / Reference pixel on axis 2 CRVAL1 = 61.5 / Value at ref. pixel on axis 1 CRVAL2 = 63.5 / Value at ref. pixel on axis 2 CTYPE1 = 'CCD_REG1' / Quantity represented by axis 1 CTYPE2 = 'CCD_REG2' / Quantity represented by axis 2 CD1_1 = 1.0 / Transformation matrix element CD2_2 = 1.0 / Transformation matrix element EXTEND = T / FITS dataset may contain extensions COMMENT FITS (Flexible Image Transport System) format is defined in 'Astronomy COMMENT and Astrophysics', volume 376, page 359; bibcode: 2001A&A...376..359H LBOUND1 = 6 / Pixel origin along axis 1 LBOUND2 = 1 / Pixel origin along axis 2 OBJECT = 'Output from TRANNDF'/ Title of the dataset DATE = '2004-02-22T22:02:27'/ file creation date (YYYY-MM-DDThh:mm:ss UT) ORIGIN = 'Starlink Project, U.K.'/ Origin of this FITS file BSCALE = 1.0 / True_value = BSCALE * FITS_value + BZERO BZERO = 0.0 / True_value = BSCALE * FITS_value + BZERO HDUCLAS1= 'NDF ' / Starlink NDF (hierarchical n-dim format) HDUCLAS2= 'DATA ' / Array component subclass CCDXIMSI= 114 CCDXIMST= 6 CCDXSIZE= 128 CCDYIMSI= 128 CCDYIMST= 1 CCDYSIZE= 128 GAIN = 1 READNOIS= 10.0 PFMFNAME= 'B ' OBSTYPE = 'TARGET ' TELESCOP= 'CCDPACK SPECIAL ' ISEQ = 1 END Astro-FITS-Header-3.08/t/bugs.t000444004077000012 1700114014777770 15615 0ustar00gbellstaff000000000000# Astro::FITS::Header test harness -*-perl-*- use strict; use Test::More tests => 4; require_ok( "Astro::FITS::Header" ); require_ok( "Astro::FITS::Header::Item" ); # Read header from DATA block. my @raw = ; chomp( @raw ); # Build the header item. my $header = new Astro::FITS::Header( Cards => \@raw ); ### Test bug where multiple headers being removed using a regular ### expression removed the wrong headers. # Remove headers that start with CR.. $header->removebyname( qr/^CR/ ); # There should still be a "CTYPE2" header, so retrieve it. my @card = $header->itembyname( "CTYPE2" ); ok( defined $card[0] ); is( $card[0]->value, "a2", "CTYPE2 is a2" ); exit; __DATA__ SIMPLE = T / file does conform to FITS standard BITPIX = -32 / number of bits per data pixel NAXIS = 3 / number of data axes NAXIS1 = 25 / length of data axis 1 NAXIS2 = 36 / length of data axis 2 NAXIS3 = 252 / length of data axis 3 EXTEND = T / FITS dataset may contain extensions COMMENT FITS (Flexible Image Transport System) format defined in Astronomy and COMMENT Astrophysics Supplement Series v44/p363, v44/p371, v73/p359, v73/p365. COMMENT Contact the NASA Science Office of Standards and Technology for the COMMENT FITS Definition document #100 and other FITS information. CRVAL1 = -0.07249999791383749 / Axis 1 reference value CRPIX1 = 12.5 / Axis 1 pixel value CTYPE1 = 'a1 ' / LINEAR CRVAL2 = -0.07249999791383743 / Axis 2 reference value CRPIX2 = 18.0 / Axis 2 pixel value CTYPE2 = 'a2 ' / LINEAR CRVAL3 = 1.27557086671004E-6 / Axis 3 reference value CRPIX3 = 126.0 / Axis 3 pixel value CTYPE3 = 'a3 ' / LAMBDA OBJECT = 'galaxy ' / Title of the dataset DATE = '2000-12-13T22:44:53' / file creation date (YYYY-MM-DDThh:mm:ss UTC) ORIGIN = 'NOAO-IRAF FITS Image Kernel July 1999' / FITS file originator BSCALE = 1.0 / True_value = BSCALE * FITS_value + BZERO BZERO = 0.0 / True_value = BSCALE * FITS_value + BZERO HDUCLAS1= 'NDF ' / Starlink NDF (hierarchical n-dim format) HDUCLAS2= 'DATA ' / Array component subclass IRAF-TLM= '23:07:26 (27/02/2000)' / Time of last modification TELESCOP= 'UKIRT, Mauna Kea, HI' / Telescope name INSTRUME= 'CGS4 ' / Instrument OBSERVER= 'SMIRF ' / Observer name(s) OBSREF = '? ' / Observer reference DETECTOR= 'fpa046 ' / Detector array used OBSTYPE = 'OBJECT ' / Type of observation INTTYPE = 'STARE+NDR' / Type of integration MODE = 'ND_STARE' / Observing mode GRPNUM = 0 / Number of observation group RUN = 54 / Number of run EXPOSED = 180 / Total exposure time for integration OBJCLASS= 0 / Class of observed object CD1_1 = 0.144999980926513672 / Axis rotation and scaling matrix CD1_2 = 0.0 / Axis rotation and scaling matrix CD1_3 = 0.0 / Axis rotation and scaling matrix CD2_1 = 0.0 / Axis rotation and scaling matrix CD2_2 = 0.144999980926513672 / Axis rotation and scaling matrix CD2_3 = 0.0 / Axis rotation and scaling matrix CD3_1 = 0.0 / Axis rotation and scaling matrix CD3_2 = 0.0 / Axis rotation and scaling matrix CD3_3 = 2.07933226192836E-10 / Axis rotation and scaling matrix MEANRA = 10.34629999999999939 / Object RA at equinox (hrs) MEANDEC = 20.1186000000000007 / Object Dec at equinox (deg) RABASE = 10.34629999999999939 / Offset zero-point RA at equinox (hrs) DECBASE = 20.1186000000000007 / Offset zero-point Dec at equinox (deg) RAOFF = 0 / Offset RA at equinox (arcsec) DECOFF = 0 / Offset Dec at equinox (arcsec) DROWS = 178 / No of det. in readout row DCOLUMNS= 256 / No of det. in readout column DEPERDN = 6 / Electrons per data number CLOCK0 = -6.20000000000000018 / ALICE CLOCK0 voltage CLOCK1 = -3 / ALICE CLOCK1 voltage CLOCK2 = -7.5 / ALICE CLOCK2 voltage CLOCK3 = -2.79999999999999982 / ALICE CLOCK3 voltage CLOCK4 = -6 / ALICE CLOCK4 voltage CLOCK5 = -2 / ALICE CLOCK5 voltage CLOCK6 = -7.5 / ALICE CLOCK6 voltage VSLEW = 4 / ALICE VSLEW voltage VDET = -3.02000000000000002 / ALICE VDET voltage DET_BIAS= 0.57999999999999996 / ALICE DET_BIAS voltage VDDUC = -3.60000000000000009 / ALICE VDDUC voltage VDETGATE= -4.5 / ALICE VDETGATE voltage VGG_A = -1.60000000000000009 / ALICE VGG_ACTIVE voltage VGG_INA = -1.30000000000000004 / ALICE VGG_INACTIVE voltage VDDOUT = -1 / ALICE VDDOUT voltage V3 = -2.79999999999999982 / ALICE V3 voltage VLCLR = -3 / ALICE VLCLR voltage VLD_A = 4 / ALICE VLOAD_ACTIVE voltage VLD_INA = 4 / ALICE VLOAD_INACTIVE voltage WFREQ = 1 / ALICE waveform state freq. (MHz) RESET_DL= 0.200000000000000011 / NDR reset delay (seconds) CHOP_DEL= 0.029999998999999999 / Chop delay (seconds) READ_INT= 5 / NDR read interval (seconds) NEXP_PH = 0 / Exposures in each chop phase DEXPTIME= 180 / Exposure time (seconds) RDOUT_X1= 1 / Start column of array readout RDOUT_X2= 256 / End column of array readout RDOUT_Y1= 45 / Start row of array readout RDOUT_Y2= 222 / End row of array readout CHOPDIFF= T / Main-offset beam value stored IF_SHARP= F / Shift & add disabled LINEAR = F / Linearisation disabled FILTER = 'B1 ' / Combined filter name FILTERS = 'B1 ' / Combined filter name DETINCR = 1 / Increment (pixels) betw scan positions DETNINCR= 2 / Number of scan positions in scan WPLANGLE= 0 / IRPOL waveplate angle SANGLE = -2.19303900000000018 / Angle of slit SLIT = '0ew ' / Name of slit SLENGTH = 18 / Length of slit SWIDTH = 4 / Width of slit DENCBASE= 800 / Zeropoint (steps) of detector translation DFOCUS = 1.819309999999999983 / Detector focus position GRATING = '150_lpmm' / Name of grating GLAMBDA = 1.274947000000000052 / Grating wavelength GANGLE = 17.09262000000000015 / Grating wavelength GORDER = 3 / Grating order GDISP = 0.00020796522 / Grating dispersion CLAMBDA = 0 / CVF wavelength IRTANGLE= 6.396519999999999762 / Image rotator angle LAMP = 'off ' / Name of calibration lamp BBTEMP = 0 / Black body temperature CALAPER = 0 / Aperture of tungsten-halogen lamp (%) THLEVEL = 0 / Level of tungsten-halogen lamp IDATE = 19980217 / Date as integer OBSNUM = 54 / Number of observation NEXP = 1 / Exposures in integration AMSTART = 1.334643999999999942 / Airmass at start of obs AMEND = 1.320149999999999935 / Airmass at end of obs RUTSTART= 8.000171999999999173 / Start time of obs (hrs) RUTEND = 8.101883000000000834 / End time of obs (hrs) NBADPIX = 32 END Astro-FITS-Header-3.08/t/cfitsio.fit000444004077000012 7570014014777770 16646 0ustar00gbellstaff000000000000SIMPLE = T / file does conform to FITS standard BITPIX = -32 / number of bits per data pixel NAXIS = 2 / number of data axes NAXIS1 = 59 / length of data axis 1 NAXIS2 = 110 / length of data axis 2 EXTEND = T / FITS dataset may contain extensions COMMENT FITS (Flexible Image Transport System) format defined in Astronomy andCOMMENT Astrophysics Supplement Series v44/p363, v44/p371, v73/p359, v73/p365.COMMENT Contact the NASA Science Office of Standards and Technology for the COMMENT FITS Definition document #100 and other FITS information. CRVAL1 = -0.03125 / Axis 1 reference value CRPIX1 = 29.5 / Axis 1 pixel value CTYPE1 = 'LINEAR ' / Quantity represented by axis 1 CRVAL2 = -0.03125 / Axis 2 reference value CRPIX2 = 55.0 / Axis 2 pixel value CTYPE2 = 'LINEAR ' / Quantity represented by axis 2 CD1_1 = 0.0625 / Axis rotation and scaling matrix CD1_2 = 0.0 / Axis rotation and scaling matrix CD2_1 = 0.0 / Axis rotation and scaling matrix CD2_2 = 0.0625 / Axis rotation and scaling matrix OBJECT = ' ' / Title of the dataset DATE = '2000-12-12T20:28:35'/ file creation date (YYYY-MM-DDThh:mm:ss UTC) ORIGIN = 'Starlink Project, U.K.'/ Origin of this FITS file BSCALE = 1.0 / True_value = BSCALE * FITS_value + BZERO BZERO = 0.0 / True_value = BSCALE * FITS_value + BZERO HDUCLAS1= 'NDF ' / Starlink NDF (hierarchical n-dim format) HDUCLAS2= 'DATA ' / Array component subclass END KsKUKKvZKvxK탂K֘KMKRK+KxKYKhK KKZ]K9KKKYKHuK@DKgK> K=KIK\ZKNmKtKwcKKK%KKKGK*KKkKKGVK2pKPKPKKJK泌KoKAKK8KڟKKKK\KKK&K =KKKK>K펂KK9KhEKl]KjK/K3_KKFK&KKKZ]KDK1KYK[KKKK(KTKDWK_SKKPKdK^vKVbK3GKzKKK K KKKŧK0KkK~KxKKKK(}KK K LK8KKK~K 0KEKXKK&KHKUK KMKcK2Km|K﹍K9K"K#K-K: KdKK KSKKm@KّKsKKK K>KZ K삆KAK_K wK5KKK{KKׂK KK5{KL/KKKK-VK@KKEKEK$qK7K2KKKﭝKKWK+K.KH-K]K\$KBKKKKKgK K#K[)KK KK30K5K0KKQKKK[K#K)KKKKK/KKK0KK%rKKüK_KKK:KiK|K K,KtKKWKﮍKaKJKSKKKdKKK$YKlKqK/KK+KKK K\KvmK -KKK|KdžK~'KKWKĽKDKKKKKK\KK-K5KJ>K$KXKXKvKKbKU%K9KKfK_K&K KMKKqK^KK4mKKK޸K K KKDKK@KCKK)KK&KKK﷐K KK]KKUKGVKAKmKKKDuKKEKMHKLKKXK@KKKKKIKoKKAKވKK9K KKeiKڽK3KKK9KxK?K*KKKK9KeKzPKK2K!NK|KKKsK=FKKKKXKFKIK4aK*KLKzKAKK=KXKKKKv2KKWKK KuKμKﾕK}KfK\KHKKIeK%KYKbKKK2KKPFK3|KcKt3KKK KcK KNK^K)KmKKKpKNK3qK3K)K3KTqK}+KﮫKK4K?KK`KKPKRKKuKnKaKK_KqK=KnKKKtKKwKKK=Kp-K>KK0KKּKK2KյKvK KK)aKDKeKKKVK~KiFKJK-K(K(5K3KM0KwKKeK K~KKԢK2KOWKK3KpKhK~KoK6Kd K$KEKޚK KtKKKKKKKPKKOK]KKDoKK9iK~KʗKԧK^KJK}IK.K KKsKhVKPK7K,K#K!K@3KnKK#K1KKɢKKK?KzK;K~KxKKAK6KUK!0K KKKznKKK=K=KԳKK#uKMKK`KzKLKKJKKK0!KijKLK*KЭKќKEK^KKK K~KsVKqKaQKMK>K(5K&KEKsK+K9K%KGK/K/KK KKpK KK0K\Kr+K/YK |KKآKJKKKآKۏKJCKgKKK'4KEKKݞKK쯲KX`KK:KrxK1KKKևKK(KK#K.Kx|KyKKvK{KjKLKAKS(KzKﰊKK!KdhKpKKYKKz KRtKloKiK}KnK9K5KKKKKUKKnK7KKvK[KKEKoK햳KK;K5KKdzK}KKKNKKKHK+KKrKKqYK}KKdK KWK6K`KaK}KLKKKLK$KKNKrKKV3KXKjK_SK@3KKKKK'FK5K KXKKKzK7KeK'KަK뺦KKq4KwcKKMKyrKK#-KKK9KKmK"JKKKuK|wK輦KK!K6KCKo KjK|K#KKrKAK~K/KYJKKFK\KV3KPKDK$KKKEK K-K?%K6|KaKKsKUK3KKسKKK굑KЦKWKKKK(eK|KKKKK&KKK3KpiKeKﮍK_KRKK KjTKd\Kp-KKKxK,xKdKmMKEKOKK]KCKBK6K"KK/KKK=K K*K$wK@KKmRKKKZKvK'KKOK2KvKًK:4KKK*KKhKKK?KѺKaoKKK{KOiK"K}KKKZKKZKXK^FKmKK(KK6KCKKKKUK:K?aK)aKKKKyKMKqKKkKK`K5KlKK퍰KcKKnjKKKXK>K K[KPKײK KK#KXlKaK KKKc0KKKkaKKK @KK+KKdKUKTKR8KXlKqKFKנKKK?K K%KMK9K0 KKK KʵKfK~KKK`KKKsKKKK!KKKSdKXKSdKQKNKGKKKtFKQKKKKKUK/KKKίKK/KPKyKt:KtKuKrxKjKaEKJ7KKǼKKrK̲K+KidKTKK*K1tK$wKK̲K^K.!KKïK?KpKKKDK8[KK2KKBK K.KDKKKH(KFKA|K6K7K\KKKQKKlQK9KKyKҪK@K KwK_GKU7KOK`7KkUK_KTKCOK)KK>K햳KݼKKqwKYK>K0KFKKSKآK[KKt:KPK=K5K;K[KkK^:KGK/KKozK2(KKKsKKu KQZK/K&KWK-KMK^K\KDK&hKKKKvKK죤K>MKKKKK~JKKKqKK"fKK{K2K'9K7KaKKKKKK K!K/K&KKKMKvK KK8KJCKtFKtdKOK yKKKkKuKW4K1K7KrKKK-mK@KGK9?KK{KKKjKKdK&K#K묹K_kKK8KKzaK(YK1tKKKǪKKXKKڽK'KK$K2KKKK:K_KX~Kc`KyKK]KKPKKK^K.KKK_KWKKKcrK\KgKKKƐKK K9KK^K1KLFKKKKK^KKKK$|KHKKlK+(KHKKMKKK~K|K̈́KKKK5KKKϟKKOKHKXBKp?KKsKKcKKhK:KKK&K.K1K햳KcKDoKK_KKzKbKK|KVtK<K+(K KK^KK$KKPKnKnK#KuKK KKfAKKuKfK삆KEKKKvK!K~KOKKKQKK KKKKKKJKMK@bKK K=uKdK`K?K KKKK;K;KKKKwKSK8CK%K8KKVK˪K콟KK쯲KkK^KKSK[^KKKxKtKK KlJKqRK'KK잜KK잺K{KUK4KKK3K!KK64KKK$LK?K;K{KuK\KTKKKKdKKKwKKdK#K펾KtKTK8aK$|K(KKPK K@KSK읬K2K"KKkKYKDKK!K KgK[K$KiK~K쒎KXKK쮆KK{KeKAKKKK*KpKrKOKJKD!KGK2KKfAKr0K;KKxdKk+Kk+Kv+KwK퍰K K훝K;KrK_K=K(wK KKEK췧KKKKK욿K~KKKEKK"OK@DKЂK K/K!K}`KzUK샲K"K7K첽K욄K`K)K$K K2KKK쭗K윽KKsKkKwhK쐯K촜KKIKKv7K!K0K KvKKRK K'K쉌KKKeK%KK#K\KhK#cK8=KmRKbKgKl KkKWKKwK[K]KglKTK힊K픶KQKAdKRzKnKKKyK`IKAdK!KqKkK@KK잺K7K}BKg`KaKkKJK KӁK2KK8KtKǑKKKK삤KoK\`KXKaKuKKK?K=KlKGKeKK&mKK;KKdKLKAKOKQKKZKKuKKK5K2K4KK-K욄K=KrKlKjKhK[KEK,KK KKKKK#KKmKKKKKK9KK>K뛣K&Kn)KK/K궽KgwKNKPRKpKYK|KKKK\KK%K) KZQK[KOoK-KK9oKgKyKAK2K KkKTMKCK={K?K;~K/pKK KKKpKK˞K_KuKp3KK],K]K)*KG1K K^QK-K3KmKMGKˌKKmK6KKueKIKK K3K\KƄKaK1KK[K K&KFKZKKȽK/K\`KKKxKKKK.KK}KGKOK뾠K~%KiKGKJ KKsKsK9KKklKKvKyKiKxKoK@KHKDKKKW:K6KmKuK]K홂K+4KK/LKK퍒KKK pKKlKK KNKSK00KKKUKGK4KMKtKKoKaKKVKKKK_KGKsK`xKN7KNKhKbKKOK7GKGKK3KTKK뛅KXKIKklK}K KTKKQKLK]KKKK KȟK K뼣K&KTKĤK rKZKKK*KKLKK5KnKCKaK0`K.KGmKK۔K K'KK,KKKKK뙦KYKD8KR%KKKTKKmK덶KKퟶKtvKKKӚK뽱KKXSKKRKRK%KvIKlK@K}KJfKLKK{KK}K믈KzKKmK4KZKOKK_KKbKK#KrKƳK뭨K뎦K KKKoKK)KGKKN1KKIK8KKmK#K떹KKKKKKKKKݣKЦKK K1KOKKԠKԾKܴKKK_K7KK!KGKKKK+KK K1K1KK&KK\KK؛K9KjK}KKKKȍKp]KK{iKKK KSKK 9KK KKEKKKeKmKKKKK'?KKGKKKWKBlKKaKZK휍KKMK|KuKkKoPKqKs,KKK.KqKK+KK~K:KKHK5KPKEKuKEkKKcAstro-FITS-Header-3.08/t/cfitsio.t000444004077000012 1161314014777770 16320 0ustar00gbellstaff000000000000#!perl # Testing CFITSIO read/write of fits headers use strict; use Test::More; BEGIN { eval "use Astro::FITS::CFITSIO qw / :longnames /; use Astro::FITS::CFITSIO qw/ :constants /;"; if ($@) { plan skip_all => "Astro::FITS::CFITSIO module not available"; exit; } else { plan tests => 41; } } use File::Spec; use File::Copy; # ---------------------------------------------------------------------------- # Copy the test data to a temporary location BEGIN{ copy( File::Spec->catfile("t", "cfitsio.fit"), File::Spec->catfile("t", "test.fit" ) ) or croak("Unable to copy test data file to temporary location"); }; # Delete the temporary copy of the test data END{ unlink File::Spec->catfile("t", "test.fit" ) or croak("Unable to delete test data"); }; # ---------------------------------------------------------------------------- require_ok( "Astro::FITS::Header::CFITSIO" ); # Read from the __DATA__ block my @cards = ; chomp(@cards); # Version test, need cfitsio library version > 2.1 ok( fits_get_version(my $version) > 2.1, "Check Astro::FITS::CFITSIO version number"); # get the path to the test data file my $file = File::Spec->catfile("t", "test.fit"); # create a header my $header = new Astro::FITS::Header::CFITSIO( File => $file ); # overwrite the header in memory with cards stored in __DATA__ # its a cheap and cheerful kludge and not the OO way to do it $header->configure( Cards => \@cards ); # write our modified header out again $header->writehdr( File => $file ); # open the header back up again reading directly from the file my $compare = new Astro::FITS::Header::CFITSIO( File => $file ); # test the header against the raw data for my $i (0 .. $#cards) { my @items = $compare->item($i); is( "$items[0]", $cards[$i], "Compare item $i"); } exit; __DATA__ SIMPLE = T / file does conform to FITS standard BITPIX = -32 / number of bits per data pixel NAXIS = 2 / number of data axes NAXIS1 = 59 / length of data axis 1 NAXIS2 = 110 / length of data axis 2 EXTEND = T / FITS dataset may contain extensions COMMENT FITS (Flexible Image Transport System) format defined in Astronomy and COMMENT Astrophysics Supplement Series v44/p363, v44/p371, v73/p359, v73/p365. COMMENT Contact the NASA Science Office of Standards and Technology for the COMMENT FITS Definition document #100 and other FITS information. CLOCK0 = -6.20000000000000018 / ALICE CLOCK0 voltage CLOCK1 = -3 / ALICE CLOCK1 voltage CLOCK2 = -7.5 / ALICE CLOCK2 voltage CLOCK3 = -2.79999999999999982 / ALICE CLOCK3 voltage CLOCK4 = -6 / ALICE CLOCK4 voltage CLOCK5 = -2 / ALICE CLOCK5 voltage CLOCK6 = -7.5 / ALICE CLOCK6 voltage CRVAL1 = -0.03125 / Axis 1 reference value CRPIX1 = 29.5 / Axis 1 pixel value CTYPE1 = 'LINEAR ' / Quantity represented by axis 1 CRVAL2 = -0.03125 / Axis 2 reference value CRPIX2 = 55.0 / Axis 2 pixel value CTYPE2 = 'LINEAR ' / Quantity represented by axis 2 CD1_1 = 0.0625 / Axis rotation and scaling matrix CD1_2 = 0.0 / Axis rotation and scaling matrix CD2_1 = 0.0 / Axis rotation and scaling matrix CD2_2 = 0.0625 / Axis rotation and scaling matrix OBJECT = ' ' / Title of the dataset DATE = '2000-12-12T20:28:35'/ file creation date (YYYY-MM-DDThh:mm:ss UTC) ORIGIN = 'Starlink Project, U.K.'/ Origin of this FITS file BSCALE = 1.0 / True_value = BSCALE * FITS_value + BZERO BZERO = 0.0 / True_value = BSCALE * FITS_value + BZERO HDUCLAS1= 'NDF ' / Starlink NDF (hierarchical n-dim format) HDUCLAS2= 'DATA ' / Array component subclass LINEAR = F / Linearisation disabled FILTER = 'B1 ' / Combined filter name FILTERS = 'B1 ' / Combined filter name LAMP = 'off ' / Name of calibration lamp END Astro-FITS-Header-3.08/t/gsd.t000444004077000012 124614014777770 15416 0ustar00gbellstaff000000000000#!perl # Testing GSD read of fits headers use strict; use Test::More; BEGIN { eval "use GSD;"; if ($@) { plan skip_all => "GSD module not available"; exit; } else { plan tests => 4; } } use File::Spec; require_ok( "Astro::FITS::Header::GSD" ); # Read-only # Try to work out whether the file is in the t directory or the parent my $gsdfile = "test.gsd"; $gsdfile = File::Spec->catfile("t","test.gsd") unless -e $gsdfile; my $hdr = new Astro::FITS::Header::GSD( File => $gsdfile ); ok( $hdr ); # Get the telescope name my $item = $hdr->itembyname( 'C1TEL' ); is( $item->value, "JCMT", "Check C1TEL"); is( $item->type, "STRING", "Check C1TEL type" ); Astro-FITS-Header-3.08/t/hierarch.t000444004077000012 7464314014777770 16461 0ustar00gbellstaff000000000000# Astro::FITS::Header HIERARCH test harness -*-perl-*- # strict use strict; #load test use Test::More tests => 378; # load modules require_ok( "Astro::FITS::Header" ); require_ok( "Astro::FITS::Header::Item" ); # T E S T H A R N E S S -------------------------------------------------- # read header from DATA block my @raw = ; chomp(@raw); # build header array my $header = new Astro::FITS::Header( Cards => \@raw ); # test the header for my $i (0 .. $#raw) { my $card = $header->item($i); is( "$card", $raw[$i], "Check item ".$card->keyword); } # test HIERARCH keywords is( $header->value("HIERARCH.ESO.OBS.NAME"), 'Photom-std-S705D', "HIERARCH.ESO.OBS.NAME" ); # Test the card parsing my @cards = $header->allitems(); is( $cards[52]->keyword(), "HIERARCH.ESO.OBS.TPLNO", "HIERARCH.ESO.OBS.TPLNO"); exit; __DATA__ SIMPLE = T / Standard FITS format (NOST-100.0) BITPIX = -32 / # of bits storing pix values NAXIS = 2 / # of axes in frame NAXIS1 = 1024 / # pixels/row NAXIS2 = 1024 / # rows (also # scan lines) ORIGIN = 'ESO-PARANAL' / European Southern Observatory DATE = '2001-04-09T23:38:34.0939' / Date this file was written (dd/mm/yyyy EXPTIME = 1.773 / Total integration time. 00:00:01.773 MJD-OBS = 52008.98484556 / Obs start 2001-04-09T23:38:10.656 DATE-OBS= '2001-04-09T23:38:10.6563' / Date of observation ORIGFILE= 'ISAACSW-STD-Ks_0009.fits' / Original File Name TELESCOP= 'ESO-VLT-U1' / ESO INSTRUME= 'ISAAC ' / Instrument used OBSERVER= ' ' / Name of observer PI-COI = ' ' / Name of PI and COI UTC = 85090.000 / 23:38:10.000 UT at start LST = 29379.086 / 08:09:39.086 LST at start OBJECT = 'STD ' / Original target RA = 129.06474 / 08:36:15.5 RA (J2000) pointing DEC = -10.23711 / -10:14:13.5 DEC (J2000) pointing EQUINOX = 2000. / Standard FK5 (years) RADECSYS= 'FK5 ' / Coordinate reference frame CRVAL1 = 129.06474 / 08:36:15.5, RA at ref pixel CRVAL2 = -10.23711 / -10:14:13.5, DEC at ref pixel CRPIX1 = 504.0 / Ref pixel in X CRPIX2 = 491.0 / Ref pixel in Y CDELT1 = 0.00004122 / SS arcsec per pixel in RA CDELT2 = -0.00004122 / SS arcsec per pixel in DEC CTYPE1 = 'RA---TAN' / pixel coordinate system CTYPE2 = 'DEC--TAN' / pixel coordinate system CROTA1 = 0.00000 / Rotation in degrees CROTA2 = 0.00000 / Rotation in degrees PC001001= 1.000000 / Translation matrix element PC001002= -0.000000 / Translation matrix element PC002001= -0.000000 / Translation matrix element PC002002= 1.000000 / Translation matrix element ARCFILE = 'ISAAC.2001-04-09T23:38:10.656.fits' / Archive File Name CHECKSUM= 'YOpYZLnYYLnYYLnY' / ASCII 1's complement checksum UT = '23:38:10.000' / UT at start ST = '08:09:39.086' / ST at start AIRMASS = 1.03900 / Averaged air mass IMAGETYP= 'STD ' / Observation type FILTER1 = 'Ks ' / Filter 1 name FILTER2 = 'open ' / Filter 2 name GRAT = 'MR ' / Grating name WLEN = 0.5 / Grating central wavelen ORDER = 1 / Grating order used DATAMIN = -1.833333 / Minimum pixel value DATAMAX = 8651.833008 / Maximum pixel value DATAMEAN= 939.563104 / Mean Pixel Value DATARMS = 103.167024 / RMS of Pixel Values DATAMED = 926.666687 / Median Pixel Value HIERARCH ESO OBS TPLNO = 5 / Template number within OB HIERARCH ESO OBS NAME = 'Photom-std-S705D' / OB name HIERARCH ESO OBS ID = 200103132 / Observation block ID HIERARCH ESO OBS GRP = '0 ' / linked blocks HIERARCH ESO OBS PROG ID = '60.A-9021(A)' / ESO program identification HIERARCH ESO OBS DID = 'ESO-VLT-DIC.OBS-1.7' / OBS Dictionary HIERARCH ESO OBS OBSERVER = 'UNKNOWN ' / Observer Name HIERARCH ESO OBS PI-COI NAME = 'UNKNOWN ' / PI-COI name HIERARCH ESO OBS PI-COI ID = 52021 / ESO internal PI-COI ID HIERARCH ESO OBS TARG NAME = 'S705-D ' / OB target name HIERARCH ESO OBS START = '2001-04-09T23:22:20' / OB start time HIERARCH ESO TPL DID = 'ESO-VLT-DIC.TPL-1.4' / Data dictionary for TPL HIERARCH ESO TPL ID = 'ISAACSW_img_tec_Zp' / Template signature ID HIERARCH ESO TPL NAME = 'Imaging. Standard Stars' / Template name HIERARCH ESO TPL PRESEQ = 'ISAAC_img_cal_StandardStar' / Sequencer script HIERARCH ESO TPL START = '2001-04-09T23:36:05' / TPL start time HIERARCH ESO TPL VERSION = '@(#) Revision: 8813 ' / Version of the templat HIERARCH ESO TPL NEXP = 5 / Number of exposures within templat HIERARCH ESO TPL EXPNO = 4 / Exposure number within template HIERARCH ESO SEQ RELOFFSETX = 0.000000 / relative X offset HIERARCH ESO SEQ RELOFFSETY = -606.469003 / relative Y offset HIERARCH ESO SEQ CUMOFFSETX = -303.234501 / cummulative X offset HIERARCH ESO SEQ CUMOFFSETY = -303.234501 / cummulative Y offset HIERARCH ESO DPR CATG = 'CALIB ' / Observation category HIERARCH ESO DPR TYPE = 'STD ' / Observation type HIERARCH ESO DPR TECH = 'IMAGE ' / Observation technique HIERARCH ESO TEL DID = 'ESO-VLT-DIC.TCS' / Data dictionary for TEL HIERARCH ESO TEL ID = 'v 1.370 ' / TCS version number HIERARCH ESO TEL DATE = '2001-04-05T19:18:04.000' / TCS installation date HIERARCH ESO TEL ALT = 74.287 / Alt angle at start (deg) HIERARCH ESO TEL AZ = 204.939 / Az angle at start (deg) S=0,W=90 HIERARCH ESO TEL GEOELEV = 2648. / Elevation above sea level (m) HIERARCH ESO TEL GEOLAT = -24.6259 / Tel geo latitute (+=North) (deg) HIERARCH ESO TEL GEOLON = -70.4032 / Tel geo longitute (+=East) (deg) HIERARCH ESO TEL OPER = 'I, Condor' / Telescope Operator HIERARCH ESO TEL FOCU ID = 'NB ' / Telescope focus station ID HIERARCH ESO TEL FOCU LEN = 120.000 / Focal length (m) HIERARCH ESO TEL FOCU SCALE = 1.718 / Focal scale (arcsec/mm) HIERARCH ESO TEL FOCU VALUE = -36.921 / M2 setting (mm) HIERARCH ESO TEL PARANG START= -157.066 / Parallactic angle at start (deg) HIERARCH ESO TEL AIRM START = 1.039 / Airmass at start HIERARCH ESO TEL AMBI FWHM START= 0.69 / Observatory Seeing queried from AS HIERARCH ESO TEL AMBI PRES START= 742.88 / Observatory ambient air pressure q HIERARCH ESO TEL AMBI WINDSP = 3.34 / Observatory ambient wind speed que HIERARCH ESO TEL AMBI WINDDIR= 298. / Observatory ambient wind directio HIERARCH ESO TEL AMBI RHUM = 15. / Observatory ambient relative humi HIERARCH ESO TEL AMBI TEMP = 13.43 / Observatory ambient temperature qu HIERARCH ESO TEL MOON RA = 145534.848451 / ~~:~~:~~.~ RA (J2000) (deg) HIERARCH ESO TEL MOON DEC = -114331.86384 / -~~:~~:~~.~ DEC (J2000) (deg) HIERARCH ESO TEL TH M1 TEMP = 12.49 / M1 superficial temperature HIERARCH ESO TEL TRAK STATUS = 'NORMAL ' / Tracking status HIERARCH ESO TEL DOME STATUS = 'FULLY-OPEN' / Dome status HIERARCH ESO TEL CHOP ST = F / True when chopping is active HIERARCH ESO TEL PARANG END = -157.372 / Parallactic angle at end (deg) HIERARCH ESO TEL AIRM END = 1.039 / Airmass at end HIERARCH ESO TEL AMBI FWHM END= 0.75 / Observatory Seeing queried from AS HIERARCH ESO TEL AMBI PRES END= 742.90 / Observatory ambient air pressure q HIERARCH ESO ADA ABSROT START= -58.62111 / Abs rot angle at exp start (deg) HIERARCH ESO ADA POSANG = 0.00000 / Position angle at start HIERARCH ESO ADA GUID STATUS = 'ON ' / Status of autoguider HIERARCH ESO ADA GUID RA = 128.897610 / 08:35:35.4 Guide star RA J2000 HIERARCH ESO ADA GUID DEC = -10.21325 / -10:12:47.7 Guide star DEC J2000 HIERARCH ESO ADA ABSROT END = -58.35361 / Abs rot angle at exp end (deg) HIERARCH ESO INS SWSIM = 'NORMAL ' / Software simulated functions HIERARCH ESO INS ID = 'ISAAC/HW 1.0/SW 1.48/' / Instrument identificati HIERARCH ESO INS TIME = '2001-04-09T23:38:34.441' / Aquired status time HIERARCH ESO INS DID = 'ESO-VLT-DIC.ISAAC_ICS-0.1' / Data dictionary for HIERARCH ESO INS MODE = 'SWI1 ' / OS Exposure completed HIERARCH ESO INS PIXSCALE = 0.148 / Pixel scale HIERARCH ESO INS TEMP-MON TEMP1= 76.750 / Status temp. scanner HIERARCH ESO INS TEMP-MON NAME1= 'Cool Down' / Sensor placement HIERARCH ESO INS TEMP-MON TEMP2= 69.330 / Status temp. scanner HIERARCH ESO INS TEMP-MON NAME2= 'Warm Up ' / Sensor placement HIERARCH ESO INS TEMP-MON TEMP3= 108.120 / Status temp. scanner HIERARCH ESO INS TEMP-MON NAME3= 'Sorption' / Sensor placement HIERARCH ESO INS TEMP-MON TEMP4= 68.450 / Status temp. scanner HIERARCH ESO INS TEMP-MON NAME4= 'Mirror ' / Sensor placement HIERARCH ESO INS TEMP-MON TEMP5= 67.830 / Status temp. scanner HIERARCH ESO INS TEMP-MON NAME5= 'Cstr #1 ' / Sensor placement HIERARCH ESO INS TEMP-MON TEMP6= 68.520 / Status temp. scanner HIERARCH ESO INS TEMP-MON NAME6= 'Cstr #2 ' / Sensor placement HIERARCH ESO INS TEMP-MON TEMP7= 68.150 / Status temp. scanner HIERARCH ESO INS TEMP-MON NAME7= 'Cstr #3 ' / Sensor placement HIERARCH ESO INS TEMP-MON TEMP8= 104.840 / Status temp. scanner HIERARCH ESO INS TEMP-MON NAME8= 'Radiation Shield' / Sensor placement HIERARCH ESO INS TEMP-MON TEMP11= 3.750 / Status temp. scanner HIERARCH ESO INS TEMP-MON NAME11= 'flowrate' / Sensor placement HIERARCH ESO INS TEMP-DETSW = 59.999 / Temp. of detector SW HIERARCH ESO INS TEMP-DETSW SET= 60.000 / Set temp. of detector SW HIERARCH ESO INS TEMP-DETLW = 29.999 / Temp. of detector LW HIERARCH ESO INS TEMP-DETLW SET= 30.000 / Set temp. of detector LW HIERARCH ESO INS LAMP1 TIME = 29 / Calibration lamp activation time HIERARCH ESO INS LAMP1 NAME = 'argon lamp' / Calibration lamp name HIERARCH ESO INS LAMP1 TYPE = 'DIGITAL ' / Calibration lamp type HIERARCH ESO INS LAMP1 ST = F / Calibration lamp activated HIERARCH ESO INS LAMP1 TOTAL = 3295 / Calibration lamp lifetime HIERARCH ESO INS LAMP2 TIME = 29 / Calibration lamp activation time HIERARCH ESO INS LAMP2 NAME = 'xenon lamp' / Calibration lamp name HIERARCH ESO INS LAMP2 TYPE = 'DIGITAL ' / Calibration lamp type HIERARCH ESO INS LAMP2 ST = F / Calibration lamp activated HIERARCH ESO INS LAMP2 TOTAL = 4846 / Calibration lamp lifetime HIERARCH ESO INS LAMP3 TIME = 266 / Calibration lamp activation time HIERARCH ESO INS LAMP3 NAME = 'halogen lamp' / Calibration lamp name HIERARCH ESO INS LAMP3 TYPE = 'ANALOG ' / Calibration lamp type HIERARCH ESO INS LAMP3 SET = 0 / Value sent to amplifier. HIERARCH ESO INS LAMP3 CURRENT= 0 / Amplifier status current HIERARCH ESO INS LAMP3 TOTAL = 14777 / Calibration lamp lifetime HIERARCH ESO INS CALSHUT ST = F / Calibration shutter activated HIERARCH ESO INS CALSHUT TIME= 87 / Calibration shutter time (msec.) HIERARCH ESO INS CALMIRR NAME= 'OUT ' / Name of mirror position HIERARCH ESO INS CALMIRR NO = 1 / Position number of calib. shutter HIERARCH ESO INS M1 ST = T / Mode select mirror T=IN F=OUT HIERARCH ESO INS OPTI1 ID = 'mask_S2 ' / OPTIi unique ID HIERARCH ESO INS OPTI1 NAME = 'mask_S2 ' / OPTIi name HIERARCH ESO INS OPTI1 NO = 7 / OPTIi slot number HIERARCH ESO INS OPTI1 TYPE = 'MASK ' / OPTIi element HIERARCH ESO INS FILT1 ID = 'Ks ' / FILTi unique ID HIERARCH ESO INS FILT1 NAME = 'Ks ' / FILTi name HIERARCH ESO INS FILT1 NO = 12 / FILTi slot number HIERARCH ESO INS FILT1 TYPE = 'FILTER ' / FILTi element HIERARCH ESO INS FILT2 ID = 'open ' / FILTi unique ID HIERARCH ESO INS FILT2 NAME = 'open ' / FILTi name HIERARCH ESO INS FILT2 NO = 2 / FILTi slot number HIERARCH ESO INS FILT2 TYPE = 'FREE ' / FILTi element HIERARCH ESO INS OPTI2 ID = 'S2 ' / OPTIi unique ID HIERARCH ESO INS OPTI2 NAME = 'S2 ' / OPTIi name HIERARCH ESO INS OPTI2 NO = 6 / OPTIi slot number HIERARCH ESO INS OPTI2 TYPE = 'OBJECTIVE' / OPTIi element HIERARCH ESO INS M7 ST = F / Det. select mirror T=LW F=SW HIERARCH ESO INS COLLIM ENC = -4000 / Collimator encoder position HIERARCH ESO INS GRAT NAME = 'MR ' / Grating device name HIERARCH ESO INS GRAT ORDER = 1 / Wavelength order number HIERARCH ESO INS GRAT WLEN = 0.5000000 / Grating central wavelength HIERARCH ESO INS GRAT ENC = 659536 / Grating encoder position HIERARCH ESO DET FRAM TYPE = 'INT ' / Type of frame HIERARCH ESO DET FRAM NO = 1 / Frame number HIERARCH ESO DET FRAM UTC = '2001-04-09T23:38:33.7973' / Time Recv Frame HIERARCH ESO DET EXP NO = 1122 / Unique exposure ID number HIERARCH ESO DET EXP UTC = '2001-04-09T23:38:34.0939' / File Creation Time HIERARCH ESO DET EXP NAME = 'ISAACSW-STD-Ks_0009' / Exposure Name HIERARCH ESO DET DID = 'ESO-VLT-DIC.IRACE-1.11' / Dictionary HIERARCH ESO DET CON OPMODE = 'NORMAL ' / Operational Mode HIERARCH ESO DET IRACE SEQCONT= F / Sequencer Cont. Mode HIERARCH ESO DET CHIP ID = 'ESO-Hawaii' / Detector ID HIERARCH ESO DET CHIP NAME = 'Hawaii ' / Detector name HIERARCH ESO DET CHIP NX = 1024 / Pixels in X HIERARCH ESO DET CHIP NY = 1024 / Pixels in Y HIERARCH ESO DET CHIP TYPE = 'IR ' / The Type of Det Chip HIERARCH ESO DET CHIP PXSPACE= 1.800e-05 / Pixel-Pixel Spacing HIERARCH ESO DET DIT = 1.7726 / Integration Time HIERARCH ESO DET NCORRS = 2 / Read-Out Mode HIERARCH ESO DET NCORRS NAME = 'Double ' / Read-Out Mode Name HIERARCH ESO DET MODE NAME = 'DoubleCorr' / DCS Detector Mode HIERARCH ESO DET DITDELAY = 0.100 / Pause Between DITs HIERARCH ESO DET NDIT = 6 / # of Sub-Integrations HIERARCH ESO DET NDITSKIP = 0 / DITs skipped at 1st.INT HIERARCH ESO DET CHOP NCYCLES= 4 / # of Chop Cycles HIERARCH ESO DET CHOP ST = F / Chopping On/Off HIERARCH ESO DET RSPEED = 6 / Read-Speed Factor HIERARCH ESO DET RSPEEDADD = 0 / Read-Speed Add HIERARCH ESO DET WIN TYPE = 0 / Win-Type: 0=SW/1=HW HIERARCH ESO DET WIN STARTX = 1.000000 / Lower Left X Ref HIERARCH ESO DET WIN STARTY = 1.000000 / Lower left Y Ref HIERARCH ESO DET WIN NX = 1024 / # of Pixels in X HIERARCH ESO DET WIN NY = 1024 / # of Pixels in Y HIERARCH ESO DET IRACE ADC1 NAME= 'LWL-ADC ' / Name for ADC Board HIERARCH ESO DET IRACE ADC1 HEADER= 0 / Header of ADC Board HIERARCH ESO DET IRACE ADC1 ENABLE= 1 / Enable ADC Board (0/1) HIERARCH ESO DET IRACE ADC1 FILTER1= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC1 FILTER2= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC1 DELAY= 3 / ADC Delay Adjustment HIERARCH ESO DET IRACE ADC2 NAME= 'LWL-ADC ' / Name for ADC Board HIERARCH ESO DET IRACE ADC2 HEADER= 0 / Header of ADC Board HIERARCH ESO DET IRACE ADC2 ENABLE= 1 / Enable ADC Board (0/1) HIERARCH ESO DET IRACE ADC2 FILTER1= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC2 FILTER2= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC2 DELAY= 3 / ADC Delay Adjustment HIERARCH ESO DET IRACE ADC3 NAME= 'LWL-ADC ' / Name for ADC Board HIERARCH ESO DET IRACE ADC3 HEADER= 0 / Header of ADC Board HIERARCH ESO DET IRACE ADC3 ENABLE= 1 / Enable ADC Board (0/1) HIERARCH ESO DET IRACE ADC3 FILTER1= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC3 FILTER2= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC3 DELAY= 3 / ADC Delay Adjustment HIERARCH ESO DET IRACE ADC4 NAME= 'LWL-ADC ' / Name for ADC Board HIERARCH ESO DET IRACE ADC4 HEADER= 0 / Header of ADC Board HIERARCH ESO DET IRACE ADC4 ENABLE= 1 / Enable ADC Board (0/1) HIERARCH ESO DET IRACE ADC4 FILTER1= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC4 FILTER2= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC4 DELAY= 3 / ADC Delay Adjustment HIERARCH ESO DET IRACE ADC5 NAME= 'LWL-ADC ' / Name for ADC Board HIERARCH ESO DET IRACE ADC5 HEADER= 0 / Header of ADC Board HIERARCH ESO DET IRACE ADC5 ENABLE= 1 / Enable ADC Board (0/1) HIERARCH ESO DET IRACE ADC5 FILTER1= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC5 FILTER2= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC5 DELAY= 3 / ADC Delay Adjustment HIERARCH ESO DET IRACE ADC6 NAME= 'LWL-ADC ' / Name for ADC Board HIERARCH ESO DET IRACE ADC6 HEADER= 0 / Header of ADC Board HIERARCH ESO DET IRACE ADC6 ENABLE= 1 / Enable ADC Board (0/1) HIERARCH ESO DET IRACE ADC6 FILTER1= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC6 FILTER2= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC6 DELAY= 3 / ADC Delay Adjustment HIERARCH ESO DET IRACE ADC7 NAME= 'LWL-ADC ' / Name for ADC Board HIERARCH ESO DET IRACE ADC7 HEADER= 0 / Header of ADC Board HIERARCH ESO DET IRACE ADC7 ENABLE= 1 / Enable ADC Board (0/1) HIERARCH ESO DET IRACE ADC7 FILTER1= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC7 FILTER2= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC7 DELAY= 3 / ADC Delay Adjustment HIERARCH ESO DET IRACE ADC8 NAME= 'LWL-ADC ' / Name for ADC Board HIERARCH ESO DET IRACE ADC8 HEADER= 0 / Header of ADC Board HIERARCH ESO DET IRACE ADC8 ENABLE= 1 / Enable ADC Board (0/1) HIERARCH ESO DET IRACE ADC8 FILTER1= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC8 FILTER2= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC8 DELAY= 3 / ADC Delay Adjustment HIERARCH ESO DET IRACE ADC9 NAME= 'SWL-ADC ' / Name for ADC Board HIERARCH ESO DET IRACE ADC9 HEADER= 0 / Header of ADC Board HIERARCH ESO DET IRACE ADC9 ENABLE= 1 / Enable ADC Board (0/1) HIERARCH ESO DET IRACE ADC9 FILTER1= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC9 FILTER2= 0 / ADC Filter Adjustment HIERARCH ESO DET IRACE ADC9 DELAY= 4 / ADC Delay Adjustment HIERARCH ESO DET MINDIT = 1.7726 / Minimum DIT HIERARCH ESO DET VOLT2 CLKHINM1= 'clk1Hi PIXEL2-3' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI1= 5.1000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM1= 'clk1Lo PIXEL2-3' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO1= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM2= 'clk2Hi PIXEL1-4' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI2= 5.1000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM2= 'clk2Lo PIXEL1-4' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO2= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM3= 'clk3Hi LSYNC1-2-3-4' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI3= 5.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM3= 'clk3Lo LSYNC1-2-3-4' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO3= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM4= 'clk4Hi LINE1-2' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI4= 5.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM4= 'clk4Lo LINE1-2' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO4= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM5= 'clk5Hi LINE3-4' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI5= 5.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM5= 'clk5Lo LINE3-4' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO5= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM6= 'clk6Hi FSYNC1-2-3-4' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI6= 5.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM6= 'clk6Lo FSYNC1-2-3-4' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO6= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM7= 'clk7Hi READ1-2-3-4' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI7= 5.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM7= 'clk7Lo READ1-2-3-4' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO7= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM8= 'clk8Hi RESET1-2-3-4' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI8= 5.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM8= 'clk8Lo RESET1-2-3-4' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO8= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM9= 'clk9Hi VDD1-2-3-4' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI9= 5.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM9= 'clk9Lo VDD1-2-3-4' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO9= 5.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM10= 'clk10Hi ' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI10= 5.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM10= 'clk10Lo ' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO10= 5.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM11= 'clk11Hi ' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI11= 0.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM11= 'clk11Lo ' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO11= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM12= 'clock12Hi' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI12= 0.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM12= 'clock12Lo' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO12= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM13= 'clock13Hi' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI13= 5.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM13= 'clock13Lo' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO13= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM14= 'clock14Hi' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI14= 0.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM14= 'clock14Lo' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO14= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM15= 'clock15Hi' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI15= 0.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM15= 'clock15Lo' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO15= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 CLKHINM16= 'clock16Hi' / Name of High Clock HIERARCH ESO DET VOLT2 CLKHI16= 0.0000 / Set Value High Clock HIERARCH ESO DET VOLT2 CLKLONM16= 'clock16Lo' / Name of Low Clock HIERARCH ESO DET VOLT2 CLKLO16= 0.0000 / Set Value Low Clock HIERARCH ESO DET VOLT2 DCNM1 = 'DC1 VRESET1-2-3-4' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC1 = 5.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM2 = 'DC2 DSUB' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC2 = 0.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM3 = 'DC3 CELLWELL' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC3 = 5.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM4 = 'DC4 VBUS' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC4 = 5.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM5 = 'DC5 HIGH1' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC5 = 5.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM6 = 'DC6 HIGH2' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC6 = 5.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM7 = 'DC7 HIGH3' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC7 = 5.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM8 = 'DC8 HIGH4' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC8 = 5.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM9 = 'DC9 VDD1-2-3-4' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC9 = 5.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM10= 'DC10 REF1 (-2-3-4)' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC10 = 7.7500 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM11= 'DC11 REF2' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC11 = 0.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM12= 'DC12 REF3' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC12 = 0.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM13= 'DC13 REF4' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC13 = 0.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM14= 'DC14 ' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC14 = 0.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM15= 'DC15 ' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC15 = 0.0000 / Set Value DC Voltage HIERARCH ESO DET VOLT2 DCNM16= 'DC16 ' / Name of DC Voltage HIERARCH ESO DET VOLT2 DC16 = 0.0000 / Set Value DC Voltage HIERARCH ESO DET CHOP FREQ = 0.000000 / Chopping Frequency HIERARCH ESO OCS COMP ID = 'SW Version 1.44 2001/04/08 22:55:51' / OS Softwa HIERARCH ESO OCS DID = 'ESO-VLT-DIC.ISAAC_OS-1.4' / Data dictionary for HIERARCH ESO OCS SELECT-ARM = 'SW ' / Detector arm COMMENT FTU-1.39/2002-11-29T15:57:11/Default.htt END Astro-FITS-Header-3.08/t/item.t000444004077000012 1143414014777770 15617 0ustar00gbellstaff000000000000#!/stardev/Perl/bin/perl -w # strict use strict; use Test::More tests => 92; # load test modules require_ok( "Astro::FITS::Header::Item"); # read comparison header from the end of the test file my @raw = ; chomp @raw; # Store the answers in an array, the index must match the index into @raw # Might be better to store in a hash indexed by the card itself # but would require us to not use my @ANSWER = ( { Keyword => 'LOGICAL', Value => 'T', Comment => 'Testing the LOGICAL type', Type => 'LOGICAL', }, { Keyword => 'INTEGER', Value => -32, Comment => 'Testing the INT type', Type => 'INT', }, { Keyword => 'FLOAT', Value => 12.5, Comment => 'Testing the FLOAT type', Type => 'FLOAT', }, { Keyword => 'UNDEF', Value => undef, Comment => 'Testing the undef type', Type => 'UNDEF', }, { Keyword => 'STRING', Value => 'string', Comment => 'Testing the STRING type', Type => 'STRING', }, { Keyword => 'LNGSTR', Value => 'a very long string that is long', Comment => 'Long string', Type => 'STRING', }, { Keyword => 'QUOTE', Value => "a ' single quote", Comment => 'Single quote', Type => 'STRING', }, { Keyword => 'ZERO', Value => "", Comment => 'Zero length quote', Type => 'STRING', }, { Keyword => 'COMMENT', Comment => 'Testing the COMMENT type', Type => 'COMMENT', }, { Keyword => 'HISTORY', Comment => ' Testing the HISTORY type', Type => 'COMMENT', }, { Keyword => 'STRANGE', Comment => ' Testing the non-standard COMMENT', Type => 'COMMENT', }, { Keyword => 'END' }, ); # Loop through the array of FITS header items # Checking that we can reconstruct a FITS header card foreach my $n (0..$#raw) { my $card = $raw[$n]; # For information # print "# $card\n"; # Create a new Item object using this card my $item = new Astro::FITS::Header::Item( Card => $card ); # Make sure the constructed card is used rather than the cached version $item->keyword( $item->keyword ); # Compare the actual card with the reconstructed version # This tests the parsing of header cards is( "$item", $card, "Compare card $n" ); # Test that the parsed card fields match what they're supposed to be # LOGICAL values are translated to booleans by the object, so must # convert values is( eval '$item->'.lc($_), ('Value' eq $_ && 'LOGICAL' eq $ANSWER[$n]{Type}) ? { T => 1, F => 0 }->{$ANSWER[$n]{$_}} : $ANSWER[$n]{$_}, "Compare method $_") foreach keys %{$ANSWER[$n]}; # Now create a new item from the bits my $item2 = new Astro::FITS::Header::Item( %{ $ANSWER[$n] }); # Compare the brand new card with the old version # This tests the construction of a card from the raw "bits" is( "$item2", $card, "Compare reconstructed card $n"); # Also compare using the equality method # first compare it with itself ok( $item->equals($item), "Is the object equal to itself?" ); # and then with the comparison card ok( $item->equals($item2),"Is the object equal to the new object?"); } # Test that the caching is working. We do this by using # a card that we know is not conformant my $c = "LNGSTR = 'a very long string that is long' /Long string "; my $i = new Astro::FITS::Header::Item( Card => $c); is("$i", $c, "test cache"); #keyword #value #comment #type #card exit; # T I M E A T T H E B A R ---------------------------------------------- __DATA__ LOGICAL = T / Testing the LOGICAL type INTEGER = -32 / Testing the INT type FLOAT = 12.5 / Testing the FLOAT type UNDEF = / Testing the undef type STRING = 'string ' / Testing the STRING type LNGSTR = 'a very long string that is long' / Long string QUOTE = 'a '' single quote' / Single quote ZERO = '' / Zero length quote COMMENT Testing the COMMENT type HISTORY Testing the HISTORY type STRANGE Testing the non-standard COMMENT END Astro-FITS-Header-3.08/t/merge.t000444004077000012 1714514014777770 15765 0ustar00gbellstaff000000000000# -*-perl-*- # Test merge header functionality # Author: Tim Jenness # Copyright (C) 2005 Particle Physics and Astronomy Research Council. # All Rights Reserved. use strict; use warnings; use Test::More tests => 39; require_ok("Astro::FITS::Header"); # Read all the fits headers my @all = ; chomp(@all); my @fits; my $i = 0; my $start = 0; while ($i <= $#all) { if ($all[$i] eq "=cut" || $i == $#all) { my $end = ( $i == $#all ? $i : $i - 1); push(@fits, new Astro::FITS::Header( Cards => [ @all[$start..$end]])); $start = $i + 1; } $i++; } # merge in list and then in scalar context my ($merged, @different) = $fits[0]->merge_primary( @fits[1..$#fits]); my $scalar = $fits[0]->merge_primary( @fits[1..$#fits] ); is($merged->sizeof, 21, "Number of cards in merged header"); is(@different, 3, "Number of diff headers"); is($merged->itembyname("RA")->value+0, 5, "RA is in merged header"); is($scalar->sizeof, 21, "Number of cards in merged header"); is($scalar->itembyname("RA")->value+0, 5, "RA is in merged header"); ok($different[0]->itembyname("UNIQUE"), "UNIQUE was not merged"); $different[0]->removebyname( "UNIQUE" ); ok($different[0]->itembyname("COMMON"), "COMMON was not merged"); $different[0]->removebyname( "COMMON" ); ok($different[1]->itembyname("COMMON"), "COMMON was not merged"); $different[1]->removebyname( "COMMON" ); for my $i (0..$#different) { is($different[$i]->sizeof, 1, "Number of diffs in header $i"); is($different[$i]->itembyname("RUN")->value, ($i+1), "Run number in diff"); ok($different[$i]->itembyname("DATE-OBS"), "DATE-OBS is not merged"); } # Now do the merge but merge unique keys to the merged header ($merged, @different) = $fits[0]->merge_primary( {merge_unique=>1}, @fits[1..$#fits]); #print "Merged: $merged\n"; is($merged->sizeof, 23, "Number of cards in merged header"); is(@different, 3, "Number of diff headers"); is($merged->itembyname("RA")->value+0, 5, "RA is in merged header"); ok($merged->itembyname("UNIQUE"), "UNIQUE was now merged"); ok(!$merged->itembyname("DATE-OBS"), "DATE-OBS was not merged"); # COMMON should be merged since it is common to 2 of the 3 # but identical in those 2 ok($merged->itembyname("COMMON"), "COMMON was now merged"); for my $i (0..$#different) { is($different[$i]->sizeof, 1, "Number of diffs in header $i"); is($different[$i]->itembyname("RUN")->value, ($i+1), "Run number in diff"); ok($different[$i]->itembyname("DATE-OBS"), "DATE-OBS is not merged"); } # Now clone the merge and test the force_return flag my $m2 = new Astro::FITS::Header( Cards => [$merged->cards] ); my ($m3, @diff3) = $merged->merge_primary( { force_return_diffs => 0}, $m2); is(@diff3, 0, "Empty diff"); ($m3, @diff3) = $merged->merge_primary( { force_return_diffs => 1}, $m2); is(@diff3, 2, "Forced non-Empty diff"); # Merge itself in list and scalar context my ($m4) = $merged->merge_primary(); is("$m4", "$merged", "Full header comparison"); is($m4->sizeof, $merged->sizeof, "Get back what we started with"); $m4 = $merged->merge_primary(); is("$m4", "$merged", "Full header comparison"); is($m4->sizeof, $merged->sizeof, "Get back what we started with"); __END__ Block 1 description: DATE-OBS= '2005-05-01T12:00:00' / observation date RA = 5. / Right Ascension of observation DEC = 5. / Declination of observation ADD_ATM = 1 / flag for adding atmospheric emission ADDFNOIS= 0 / flag for adding 1/f noise ADD_PNS = 1 / flag for adding photon noise FLUX2CUR= 1 / flag for converting flux to current SMU_SAMP= 8 / number of samples between jiggle vertices DISTFAC = 0. / distortion factor (0=no distortion) CONVSHAP= 2 / convolution function (Gaussian=0) CONV_SIG= 1. / convolution function parameter NBOLX = 40 / number of bolometers in X direction NBOLY = 32 / number of bolometers in Y direction SAMPLE_T= 5. / The sample interval in msec SUBSYSNR= 1 / subsystem number NVERT = 8 / Nr of vertices in the Jiggle pattern MOVECODE= 8 / Code for the SMU move algorithm HIERARCH JIG_STEPX = 12.56 / The Jiggle step value in -X-direction on the sk HIERARCH JIG_STEPY = 12.56 / The Jiggle step value in -Y-direction on the sk NCYCLE = 4 / number of cycles NUMSAMP = 256 / number of samples Block 2 description: RUN = 1 / Run number UNIQUE = 1 / A unique header COMMON = T / A somewhat common header =cut Block 1 description: DATE-OBS= '2005-05-01T12:01:00' / observation date RA = 5. / Right Ascension of observation DEC = 5. / Declination of observation ADD_ATM = 1 / flag for adding atmospheric emission ADDFNOIS= 0 / flag for adding 1/f noise ADD_PNS = 1 / flag for adding photon noise FLUX2CUR= 1 / flag for converting flux to current SMU_SAMP= 8 / number of samples between jiggle vertices DISTFAC = 0. / distortion factor (0=no distortion) CONVSHAP= 2 / convolution function (Gaussian=0) CONV_SIG= 1. / convolution function parameter NBOLX = 40 / number of bolometers in X direction NBOLY = 32 / number of bolometers in Y direction SAMPLE_T= 5. / The sample interval in msec SUBSYSNR= 1 / subsystem number NVERT = 8 / Nr of vertices in the Jiggle pattern MOVECODE= 8 / Code for the SMU move algorithm HIERARCH JIG_STEPX = 12.56 / The Jiggle step value in -X-direction on the sk HIERARCH JIG_STEPY = 12.56 / The Jiggle step value in -Y-direction on the sk NCYCLE = 4 / number of cycles NUMSAMP = 256 / number of samples Block 2 description: RUN = 2 / Run number COMMON = T / A somewhat common header =cut Block 1 description: DATE-OBS= '2005-05-01T12:02:00' / observation date RA = 5. / Right Ascension of observation DEC = 5. / Declination of observation ADD_ATM = 1 / flag for adding atmospheric emission ADDFNOIS= 0 / flag for adding 1/f noise ADD_PNS = 1 / flag for adding photon noise FLUX2CUR= 1 / flag for converting flux to current SMU_SAMP= 8 / number of samples between jiggle vertices DISTFAC = 0. / distortion factor (0=no distortion) CONVSHAP= 2 / convolution function (Gaussian=0) CONV_SIG= 1. / convolution function parameter NBOLX = 40 / number of bolometers in X direction NBOLY = 32 / number of bolometers in Y direction SAMPLE_T= 5. / The sample interval in msec SUBSYSNR= 1 / subsystem number NVERT = 8 / Nr of vertices in the Jiggle pattern MOVECODE= 8 / Code for the SMU move algorithm HIERARCH JIG_STEPX = 12.56 / The Jiggle step value in -X-direction on the sk HIERARCH JIG_STEPY = 12.56 / The Jiggle step value in -Y-direction on the sk NCYCLE = 4 / number of cycles Block 2 description: NUMSAMP = 256 / number of samples RUN = 3 / Run number Astro-FITS-Header-3.08/t/ndf.t000444004077000012 4222014014777770 15425 0ustar00gbellstaff000000000000#!perl # Testing NDF read/write of fits headers use strict; use Test::More; BEGIN { eval "use NDF;"; if ($@) { plan skip_all => "NDF module not available"; exit; } else { plan tests => 385; } } require_ok( "Astro::FITS::Header::NDF" ); my $file = "temp$$"; END { unlink $file . ".sdf" if defined $file; }; # Create an NDF file my $status = &NDF::SAI__OK; my $good = $status; ndf_begin(); ndf_open(&NDF::DAT__ROOT(), $file, 'WRITE', 'UNKNOWN', my $ndfid, my $place, $status); # if the file was not there we have to create it from the place holder # KLUGE : need to get NDF__NOID from the NDF module at some point if ($ndfid == 0) { my @lbnd = (1); my @ubnd = (1); ndf_new('_INTEGER', 1, @lbnd, @ubnd, $place, $ndfid, $status ); # Map the data array ndf_map($ndfid, 'DATA', '_INTEGER', 'WRITE', my $pntr, my $el, $status); my @data = (5); &array2mem(\@data, "i*", $pntr) if ($status == $good); ndf_unmap($ndfid,'DATA', $status); } ndf_annul($ndfid, $status); ndf_end($status); # Read the stuff from the end my @cards = ; chomp(@cards); # Create a new object with those cards my $hdr = new Astro::FITS::Header::NDF( Cards => \@cards ); # Store them on disk $hdr->writehdr( File => $file ); ok( -e $file .".sdf", "Does $file exist?" ); # Read them back in my $hdr2 = new Astro::FITS::Header::NDF( File => $file ); # Now compare with the original my @newcards = $hdr2->cards; for my $i (0..$#cards) { is($newcards[$i], $cards[$i], "Compare card $i"); } # Create an error condition my $hdr3; eval { $hdr3 = Astro::FITS::Header::NDF->new( File => "NotThere.sdf" ); }; ok( !defined $hdr3, "Deliberate error" ); # Now read the header using an NDF identifier $status = $good; err_begin( $status ); ndf_begin(); ndf_find( &NDF::DAT__ROOT(), $file, $ndfid, $status); my $hdr4 = Astro::FITS::Header::NDF->new( ndfID => $ndfid ); # Now compare with the original @newcards = $hdr2->cards; for my $i (0..$#cards) { is($newcards[$i], $cards[$i], "Compare card $i"); } ndf_end($status ); err_end( $status ); exit; __DATA__ SIMPLE = T / file does conform to FITS standard BITPIX = -32 / number of bits per data pixel NAXIS = 3 / number of data axes NAXIS1 = 5 / length of data axis 1 NAXIS2 = 37 / length of data axis 2 NAXIS3 = 32 / length of data axis 3 EXTEND = T / FITS dataset may contain extensions COMMENT FITS (Flexible Image Transport System) format defined in Astronomy and COMMENT Astrophysics Supplement Series v44/p363, v44/p371, v73/p359, v73/p365. COMMENT Contact the NASA Science Office of Standards and Technology for the COMMENT FITS Definition document #100 and other FITS information. DATE = '2001-03-17T05:32:30' / file creation date (YYYY-MM-DDThh:mm:ss UTC) ORIGIN = 'Starlink Project, U.K.' / Origin of this FITS file BSCALE = 1.0E+00 / True_value = BSCALE * FITS_value + BZERO BZERO = 0.0E+00 / True_value = BSCALE * FITS_value + BZERO HDUCLAS1= 'NDF ' / Starlink NDF (hierarchical n-dim format) HDUCLAS2= 'DATA ' / Array component subclass ACCEPT = 'PROMPT ' / accept update; PROMPT, YES or NO ALIGN_AX= 'not used' / Alignment measurements in X or Y axis ALIGN_SH= -1 / Distance between successive alignment offsets ( ALT-OBS = 4092 / Height of observatory above sea level (metres) AMEND = 1.033522 / Airmass at end of observation AMSTART = 1.033343 / Airmass at start of observation APEND = 626.6301 / Air pressure at end of observation (mbar) APSTART = 626.5079 / Air pressure at start of observation (mbar) ATEND = -0.695969 / Air temp. at end of observation (C) ATSTART = -0.793648 / Air temp. at start of observation (C) BOLOMS = 'LONG ' / Names of bolometers measured CALIBRTR= T / Internal calibrator is on or off CAL_FRQ = 2.929688 / Calibrator frequency (Hz) CENT_CRD= 'RJ ' / Centre coordinate system CHOP_CRD= 'AZ ' / Chopper coordinate system CHOP_FRQ= 7.8125 / Chopper frequency (Hz) CHOP_FUN= 'SCUBAWAVE' / Chopper waveform CHOP_PA = 90 / Chopper P.A., 0 = in lat, 90 = in long CHOP_THR= 60 / Chopper throw (arcsec) DATA_DIR= '20010316' / Sub-directory where datafile was stored DATA_KPT= 'DEMOD ' / The type of data stored to disk DRGROUP = 'UNKNOWN ' / Pipeline combination of observations DRRECIPE= 'UNKNOWN ' / Data reduction recipe name END_AZD = 349.946 / Azimuth at end of observation (deg) END_EL = -1 / Elevation of last SKYDIP point (deg) END_ELD = 75.3348 / Elevation at end of observation EQUINOX = 2000 / Equinox of mean coordinate system EXPOSED = 0 / Exposure per pixel (seconds) EXP_NO = 1 / Exposure number at end of observation EXP_TIME= 1.024 / Exposure time for each basic measurement (sec) E_PER_I = 1 / Number of exposures per integration FILTER = '450W:850W' / Filters used FOCUS_SH= -1 / Shift between focus measurements (mm) GAIN = 10 / Programmable gain HSTEND = '5:10:43.99967' / HST at end of observation HSTSTART= '5:09:42.00073' / HST at start of observation HUMEND = 15 / Humidity (%) at end of observation HUMSTART= 15 / Humidity (%) at start of observation INSTRUME= 'SCUBA ' / Name of instrument used INT_NO = 1 / Integration number at end of observation JIGL_CNT= 16 / Number of offsets in jiggle pattern JIGL_NAM= 'JCMTDATA_DIR:EASY_16_6P18.JIG' / File containing jiggle offsets J_PER_S = 16 / Number of jiggles per switch position J_REPEAT= 1 / No. jiggle pattern repeats in a switch LAT = '+034:12:47.91' / Object latitude LAT-OBS = 19.8258323669 / Latitude of observatory (degrees) LAT2 = 'not used' / Object latitude at MJD2 LOCL_CRD= 'RJ ' / Local offset coordinate system LONG = '+016:13:41.06' / Object longitude LONG-OBS= 204.520278931 / East longitude of observatory (degrees) LONG2 = 'not used' / Object Longitude at MJD2 MAP_HGHT= 180 / Height of rectangle to be mapped (arcsec) MAP_PA = 0 / P.A. of map vertical, +ve towards +ve long MAP_WDTH= 180 / Width of rectangle to be mapped (arcsec) MAP_X = 0 / Map X offset from telescope centre (arcsec) MAP_Y = 0 / Map Y offset from telescope centre (arcsec) MAX_EL = -1 / Max elevation of sky-dip (deg) MEANDEC = 34.20982 / 34:12:35.36499 = approx. mean Dec. (deg) MEANRA = 243.4202 / 243:25:12.59766 = approx. mean R.A. (deg) MEAS_NO = 1 / Measurement number at end of observation MIN_EL = -1 / Min elevation of sky-dip (deg) MJD1 = -1 / Modified Julian day planet at RA,DEC MJD2 = -1 / Modified Julian day planet at RA2,DEC2 MODE = 'POINTING' / The type of observation N_INT = 1 / No. integrations in the observation N_MEASUR= 1 / No. measurements in the observation OBJECT = '1611+343' / Name of object OBJ_TYPE= 'UNKNOWN ' / Type of object OBSDEF = 'ss:odfsxpo.t_1611x343_050456' / The observation definition file OBSERVER= 'Captain Nemo' / The name of the observer PROJ_ID = 'scuba ' / The project identification RUN = 101 / Run number of observation SAM_CRDS= 'NA ' / Coordinatesystem of sampling mesh SAM_DX = -1 / Sample spacing along scan direction (arcsec) SAM_DY = -1 / Sample spacing perp. to scan (arcsec) SAM_MODE= 'JIGGLE ' / Sampling method SAM_PA = -1 / Scan P.A. rel. to lat. line; 0=lat, 90=long SCAN_REV= F / .TRUE. if alternate scans reverse direction SPK_NSIG= 0 / N sigmas from fit of spike threshold SPK_RMVL= T / Automatic spike removal SPK_WDTH= 0 / Assumed width of spike START_EL= -1 / Elevation of first SKYDIP point (deg) STATE = 'Terminating :' / SCUCD state STEND = '16:25:54.10538' / ST at end of observation STRT_AZD= 350.459 / Azimuth at observation start (deg) STRT_ELD= 75.364 / Elevation at observation start (deg) STSTART = '16:24:52.939' / ST at start of observation SWTCH_MD= 'BMSW ' / Switch mode of observation SWTCH_NO= 2 / Switch number at end of observation S_PER_E = 2 / Number of switch positions per exposure TELESCOP= 'JCMT ' / Name of telescope TEL_OPER= 'Ned Land' / Telescope operator UTDATE = '2001:3:16' / UT date of observation UTEND = '15:10:42.99889' / UT at end of observation UTSTART = '15:09:42.00073' / UT at start of observation VERSION = 1.1 / SCUCD version WPLTNAME= 'JCMTDATA_DIR:WPLATE_16.DAT' / File name of waveplate positions ALIGN_DX= 0.724521 / SMU tables X axis alignment offset ALIGN_DY= -0.09 / SMU tables Y axis alignment offset ALIGN_X = -4.26865 / SMU tables X axis ALIGN_Y = 2.61996 / SMU tables Y axis AZ_ERR = -0.277546 / Error in the telescope azimuth CHOPPING= T / SMU Chopper chopping state EL_ERR = 1.12316 / Error in the telescope elevation FOCUS_DZ= -0.071401 / SMU tables Z axis focus offset FOCUS_Z = -16.6062 / SMU tables Z axis SEEING = 0.288833 / SAO atmospheric seeing SEE_DATE= '0103161415' / Date and time of SAO seeing TAU_225 = 0.035 / CSO tau TAU_DATE= '0103161455' / Date and time of CSO tau TAU_RMS = 3.0E-03 / CSO tau rms UAZ = -0.402539 / User azimuth pointing offset UEL = 3.99758 / User elevation pointing offset UT_DATE = '16 MAR 2001' / UT date at start of observation BAD_LIM = 32 / No. spikes before quality set bad CALIB_LG= 6 / Lag of internal calibrator in samples CALIB_PD= 42.66667 / Period of internal calibrator in samples CHOP_LG = 4 / Chop lag in samples CHOP_PD = 16 / Chop period in samples CNTR_DU3= 0 / Nasmyth dU3 coord of instrument centre CNTR_DU4= 0 / Nasmyth dU4 coord of instrument centre ETATEL_1= -1 / Transmission of telescope ETATEL_2= -1 / Transmission of telescope ETATEL_3= -1 / Transmission of telescope ETATEL_4= -1 / Transmission of telescope ETATEL_5= -1 / Transmission of telescope FILT_1 = '850 ' / Filter name FILT_2 = 'not_used' / Filter name FILT_3 = 'not_used' / Filter name FILT_4 = 'not_used' / Filter name FILT_5 = 'not_used' / Filter name FLAT = 'jcmtdata_dir:lwswphot.dat' / Name of flat-field file JIG_DSCD= -1 / No. samples discarded after jiggle movement L_GD_BOL= 'H7 ' / Bol. to whose value LW guard ring is set L_GUARD = F / Long wave guard ring on or off MEAS_BOL= 'LONG ' / Bolometers actually measured in observation N_BOLS = 37 / Number of bolometers selected N_SUBS = 1 / Number of sub-instruments used PHOT_BBF= 'not_used LL,C14,NULL' / The bolometers on the source PRE_DSCD= 0 / No. of samples discarded before chop movement PST_DSCD= 0 / No. samples discarded after chop movement REBIN = 'LINEAR ' / Rebinning method used by SCUIP REF_ADC = -1 / A/D card of FLATFIELD reference bolometer REF_CHAN= -1 / Channel of FLATFIELD reference bolometer SAM_TIME= 125 / A/D sample period in ticks (64musec) SIMULATE= F / True if data is simulated SKY = 'jcmtdata_dir:skydip_startup.dat' / Name of sky opacities file SUB_1 = 'LONG ' / SCUBA instrument being used SUB_2 = 'not used' / SCUBA instrument being used SUB_3 = 'not used' / SCUBA instrument being used SUB_4 = 'not used' / SCUBA instrument being used SUB_5 = 'not used' / SCUBA instrument being used S_GD_BOL= 'D9 ' / Bol. to whose value SW guard ring is set S_GUARD = F / Short wave guard ring on or off TAUZ_1 = 0 / Zenith sky optical depth TAUZ_2 = 0 / Zenith sky optical depth TAUZ_3 = 0 / Zenith sky optical depth TAUZ_4 = 0 / Zenith sky optical depth TAUZ_5 = 0 / Zenith sky optical depth T_AMB = -1 / The ambient air temperature (K) T_COLD_1= -1 / Effective temperature of cold load (K) T_COLD_2= -1 / Effective temperature of cold load (K) T_COLD_3= -1 / Effective temperature of cold load (K) T_COLD_4= -1 / Effective temperature of cold load (K) T_COLD_5= -1 / Effective temperature of cold load (K) T_HOT = -1 / The temperature of the hot load (K) T_TEL = -1 / The temperature of the telescope USE_CAL = F / .TRUE. if dividing chop by cal before rebin WAVE_1 = 863 / Wavelength of map (microns) WAVE_2 = 0 / Wavelength of map (microns) WAVE_3 = 0 / Wavelength of map (microns) WAVE_4 = 0 / Wavelength of map (microns) WAVE_5 = 0 / Wavelength of map (microns) END Astro-FITS-Header-3.08/t/parse.t000444004077000012 3435614014777770 16003 0ustar00gbellstaff000000000000# Astro::FITS::Header test harness -*-perl-*- # strict use strict; #load test use Test::More tests => 165; # load modules require_ok("Astro::FITS::Header"); require_ok("Astro::FITS::Header::Item"); # T E S T H A R N E S S -------------------------------------------------- # read header from DATA block my @raw = ; chomp(@raw); # build header array my $header = new Astro::FITS::Header( Cards => \@raw ); # test the header for my $i (0 .. $#raw) { my $card = $header->item($i); $card->card( undef ); # clear cache is( "$card", $raw[$i], "Compare card for keyword ". $card->keyword); } # See how many items we have of INT type my @integers = $header->itembytype( "INT" ); is( scalar(@integers), 46, "Count number of INT keywords"); # build a test card my $int_card = new Astro::FITS::Header::Item( Keyword => 'LIFE', Value => 42, Comment => 'Life the Universe and everything', Type => 'INT' ); # build another my $string_card = new Astro::FITS::Header::Item( Keyword => 'STUFF', Value => 'Blah Blah Blah', Comment => 'So long and thanks for all the fish', Type => 'STRING' ); # and another my $another_card = new Astro::FITS::Header::Item( Keyword => 'VALUE', Value => 34.5678, Comment => 'A floating point number', Type => 'FLOAT' ); # and one that contains embedded quotes my $quote_card = new Astro::FITS::Header::Item( Keyword=>'STRSTR', Value => "She said 'Foo!' (\"really?\")", Comment=> "It was 'foobar'.", Type => 'STRING'); # Check quoting my $qcstr = $quote_card->card; my $qtstr1 = "STRSTR = 'She said ''Foo!'' (\"really?\")'"; my $qtstr2 = "/ It was 'foobar'."; is(substr($qcstr,0,length($qtstr1)), $qtstr1,"Quote check 1"); is(substr($qcstr,index($qcstr,'/',length($qtstr1)),length($qtstr2)), $qtstr2, "Quote check 2"); # insert $header->insert(1, $int_card); # value my @test_value = $header->value('LIFE'); is($test_value[0], 42, "Value of LIFE"); # itembyname my @itembyname = $header->itembyname('LIFE'); is("$int_card","$itembyname[0]","Check LIFE card"); # item my @item = $header->item(1); is("$int_card","$itembyname[0]", "Check item 1 is int_card"); # splice my @cards = $header->splice( 0, 6, $string_card); my @comp = ( $raw[0], $int_card, $raw[1], $raw[2], $raw[3], $raw[4] ); for my $i (0 .. $#cards) { is( "$cards[$i]", "$comp[$i]","Splice removal"); } my $first = $header->item(0); is( "$first", "$string_card", "Check item 0"); $first = $header->splice(0,1); is( "$first", "$string_card", "Check removed item 0"); # item my $test_item = $header->item(1); is( "$test_item", $raw[6], "Check item 1" ); # itembyname my @comments = $header->itembyname('COMMENT'); is( scalar(@comments), 4, "Count number of comments"); for my $j (0 .. $#comments) { is( "$comments[$j]", "$raw[$j+7]", "Compare comment $j"); } # index my @index = $header->index('COMMENT'); my @actual = (2,3,4,5); for my $k (0 .. $#index ) { is( $index[$k], $actual[$k], "Compare comment position $k" ); } # insert $header->insert(5, $string_card); # comment my @comment = $header->comment('STUFF'); is( "$comment[0]", "So long and thanks for all the fish", "Check comment"); # replacebyname my $replacebyname = $header->replacebyname('STUFF', $int_card); is("$string_card","$replacebyname","Replaced STUFF by name"); # replace my $replace = $header->replace(5, $another_card); is("$int_card","$replace", "Replacement by index"); # value my @floating = $header->value('VALUE'); is($floating[0],34.5678, "Got first VALUE"); # remove my $remove = $header->remove(5); is("$another_card","$remove","Removed by position"); @floating = $header->value('VALUE'); is($floating[0],undef,"Got no VALUE"); # insert $header->insert(5, $string_card); # removebyname my $removebyname = $header->removebyname('STUFF'); is("$string_card","$removebyname","Was STUFF removed"); # check regular expressions @index = $header->index( qr/CLOCK\d/ ); @actual = (53..59); is( scalar @index, scalar @actual, "Count expected number of CLOCK matches" ); while( @index ) { is( shift @index, shift @actual, "Compare CLOCK keyword location" ); } # Check a card that has caused trouble in the past. my $dut = Astro::FITS::Header::Item->new( Card => 'DUT1 = -1.83507724076233E-6/ [d] UT1-UTC correction ' ); my $value = $dut->value; ok( $value < 0 && $value > -2.0E-6, "Check range of DUT1 ('$value')"); exit; __DATA__ SIMPLE = T / file does conform to FITS standard BITPIX = -32 / number of bits per data pixel NAXIS = 3 / number of data axes NAXIS1 = 25 / length of data axis 1 NAXIS2 = 36 / length of data axis 2 NAXIS3 = 252 / length of data axis 3 EXTEND = T / FITS dataset may contain extensions COMMENT FITS (Flexible Image Transport System) format defined in Astronomy and COMMENT Astrophysics Supplement Series v44/p363, v44/p371, v73/p359, v73/p365. COMMENT Contact the NASA Science Office of Standards and Technology for the COMMENT FITS Definition document #100 and other FITS information. CRVAL1 = -0.07249999791383749 / Axis 1 reference value CRPIX1 = 12.5 / Axis 1 pixel value CTYPE1 = 'a1 ' / LINEAR CRVAL2 = -0.07249999791383743 / Axis 2 reference value CRPIX2 = 18.0 / Axis 2 pixel value CTYPE2 = 'a2 ' / LINEAR CRVAL3 = 1.27557086671004E-6 / Axis 3 reference value CRPIX3 = 126.0 / Axis 3 pixel value CTYPE3 = 'a3 ' / LAMBDA OBJECT = 'galaxy ' / Title of the dataset DATE = '2000-12-13T22:44:53' / file creation date (YYYY-MM-DDThh:mm:ss UTC) ORIGIN = 'NOAO-IRAF FITS Image Kernel July 1999' / FITS file originator BSCALE = 1.0 / True_value = BSCALE * FITS_value + BZERO BZERO = 0.0 / True_value = BSCALE * FITS_value + BZERO HDUCLAS1= 'NDF ' / Starlink NDF (hierarchical n-dim format) HDUCLAS2= 'DATA ' / Array component subclass IRAF-TLM= '23:07:26 (27/02/2000)' / Time of last modification TELESCOP= 'UKIRT, Mauna Kea, HI' / Telescope name INSTRUME= 'CGS4 ' / Instrument OBSERVER= 'SMIRF ' / Observer name(s) OBSREF = '? ' / Observer reference DETECTOR= 'fpa046 ' / Detector array used OBSTYPE = 'OBJECT ' / Type of observation INTTYPE = 'STARE+NDR' / Type of integration MODE = 'ND_STARE' / Observing mode GRPNUM = 0 / Number of observation group RUN = 54 / Number of run EXPOSED = 180 / Total exposure time for integration OBJCLASS= 0 / Class of observed object CD1_1 = 0.144999980926513672 / Axis rotation and scaling matrix CD1_2 = 0.0 / Axis rotation and scaling matrix CD1_3 = 0.0 / Axis rotation and scaling matrix CD2_1 = 0.0 / Axis rotation and scaling matrix CD2_2 = 0.144999980926513672 / Axis rotation and scaling matrix CD2_3 = 0.0 / Axis rotation and scaling matrix CD3_1 = 0.0 / Axis rotation and scaling matrix CD3_2 = 0.0 / Axis rotation and scaling matrix CD3_3 = 2.07933226192836E-10 / Axis rotation and scaling matrix MEANRA = 10.34629999999999939 / Object RA at equinox (hrs) MEANDEC = 20.1186000000000007 / Object Dec at equinox (deg) RABASE = 10.34629999999999939 / Offset zero-point RA at equinox (hrs) DECBASE = 20.1186000000000007 / Offset zero-point Dec at equinox (deg) RAOFF = 0 / Offset RA at equinox (arcsec) DECOFF = 0 / Offset Dec at equinox (arcsec) DROWS = 178 / No of det. in readout row DCOLUMNS= 256 / No of det. in readout column DEPERDN = 6 / Electrons per data number CLOCK0 = -6.20000000000000018 / ALICE CLOCK0 voltage CLOCK1 = -3 / ALICE CLOCK1 voltage CLOCK2 = -7.5 / ALICE CLOCK2 voltage CLOCK3 = -2.79999999999999982 / ALICE CLOCK3 voltage CLOCK4 = -6 / ALICE CLOCK4 voltage CLOCK5 = -2 / ALICE CLOCK5 voltage CLOCK6 = -7.5 / ALICE CLOCK6 voltage VSLEW = 4 / ALICE VSLEW voltage VDET = -3.02000000000000002 / ALICE VDET voltage DET_BIAS= 0.57999999999999996 / ALICE DET_BIAS voltage VDDUC = -3.60000000000000009 / ALICE VDDUC voltage VDETGATE= -4.5 / ALICE VDETGATE voltage VGG_A = -1.60000000000000009 / ALICE VGG_ACTIVE voltage VGG_INA = -1.30000000000000004 / ALICE VGG_INACTIVE voltage VDDOUT = -1 / ALICE VDDOUT voltage V3 = -2.79999999999999982 / ALICE V3 voltage VLCLR = -3 / ALICE VLCLR voltage VLD_A = 4 / ALICE VLOAD_ACTIVE voltage VLD_INA = 4 / ALICE VLOAD_INACTIVE voltage WFREQ = 1 / ALICE waveform state freq. (MHz) RESET_DL= 0.200000000000000011 / NDR reset delay (seconds) CHOP_DEL= 0.029999998999999999 / Chop delay (seconds) READ_INT= 5 / NDR read interval (seconds) NEXP_PH = 0 / Exposures in each chop phase DEXPTIME= 180 / Exposure time (seconds) RDOUT_X1= 1 / Start column of array readout RDOUT_X2= 256 / End column of array readout RDOUT_Y1= 45 / Start row of array readout RDOUT_Y2= 222 / End row of array readout CHOPDIFF= T / Main-offset beam value stored IF_SHARP= F / Shift & add disabled LINEAR = F / Linearisation disabled FILTER = 'B1 ' / Combined filter name FILTERS = 'B1 ' / Combined filter name DETINCR = 1 / Increment (pixels) betw scan positions DETNINCR= 2 / Number of scan positions in scan WPLANGLE= 0 / IRPOL waveplate angle SANGLE = -2.19303900000000018 / Angle of slit SLIT = '0ew ' / Name of slit SLENGTH = 18 / Length of slit SWIDTH = 4 / Width of slit DENCBASE= 800 / Zeropoint (steps) of detector translation DFOCUS = 1.819309999999999983 / Detector focus position GRATING = '150_lpmm' / Name of grating GLAMBDA = 1.274947000000000052 / Grating wavelength GANGLE = 17.09262000000000015 / Grating wavelength GORDER = 3 / Grating order GDISP = 0.00020796522 / Grating dispersion CNFINDEX= 75488 / Index increments when h/w config changes CVF = 'open ' / Name of CVF CLAMBDA = 0 / CVF wavelength IRTANGLE= 6.396519999999999762 / Image rotator angle LAMP = 'off ' / Name of calibration lamp BBTEMP = 0 / Black body temperature CALAPER = 0 / Aperture of tungsten-halogen lamp (%) THLEVEL = 0 / Level of tungsten-halogen lamp IDATE = 19980217 / Date as integer OBSNUM = 54 / Number of observation NEXP = 1 / Exposures in integration AMSTART = 1.334643999999999942 / Airmass at start of obs AMEND = 1.320149999999999935 / Airmass at end of obs RUTSTART= 8.000171999999999173 / Start time of obs (hrs) RUTEND = 8.101883000000000834 / End time of obs (hrs) NBADPIX = 32 END Astro-FITS-Header-3.08/t/subhdr.t000444004077000012 1155714014777770 16156 0ustar00gbellstaff000000000000#!perl # Test that sub-headers work correctly # Needs a better suite of tests. use strict; use Test::More tests => 28; require_ok( "Astro::FITS::Header" ); require_ok( "Astro::FITS::Header::Item"); # Force numify to return the actual object reference. # This allows us to verify that a header stored through # a tie does not get reblessed or stringified. package Astro::FITS::Header; use overload '0+' => 'fudge', fallback => 1; sub fudge { return $_[0] } package main; # build a test card my $int_card = new Astro::FITS::Header::Item( Keyword => 'LIFE', Value => 42, Comment => 'Life the Universe and everything', Type => 'INT' ); # build another my $string_card = new Astro::FITS::Header::Item( Keyword => 'STUFF', Value => 'Blah Blah Blah', Comment => 'So long and thanks for all the fish', Type => 'STRING' ); # and another my $another_card = new Astro::FITS::Header::Item( Keyword => 'VALUE', Value => 34.5678, Comment => 'A floating point number', Type => 'FLOAT' ); # and another for the array my $x = "AA"; my @h1 = map { $x++; new Astro::FITS::Header::Item( Keyword => "H1$x", Value => $x, Comment => "$x th header", Type => "STRING", )} (0..5); my @h2 = map { $x++; new Astro::FITS::Header::Item( Keyword => "H2$x", Value => $x, Comment => "$x th header", Type => "STRING", )} (0..5); # Form a header my $hdr = new Astro::FITS::Header( Cards => [ $int_card, $string_card ]); # and another header my $subhdr = new Astro::FITS::Header( Cards => [ $another_card ]); print "# Subhdr: $subhdr\n"; # now create an item pointing to that subhdr my $subitem = new Astro::FITS::Header::Item( Keyword => 'EXTEND', Value => $subhdr, ); # Add the item $hdr->insert(0,$subitem); # Now use the alternate array based interface my $h1 = new Astro::FITS::Header( Cards => \@h1); my $h2 = new Astro::FITS::Header( Cards => \@h2); $hdr->subhdrs( $h1, $h2); my @ret = $hdr->subhdrs; is( scalar(@ret), 2, "Count number of subheaders"); #tie my %header; tie %header, ref($hdr), $hdr; # Add another item $header{EXTEND2} = $subhdr; is($header{EXTEND2}{VALUE},34.5678 ); # test that we have the correct type # This should be a hash is( ref($header{EXTEND}), "HASH"); # And this should be an Astro::FITS::Header isa_ok( $hdr->value("EXTEND"), "Astro::FITS::Header"); # Now store a hash $header{NEWHASH} = { A => 2, B => 3}; is( $header{NEWHASH}->{A}, 2); is( $header{NEWHASH}->{B}, 3); # Now store a tied hash my %sub; tie %sub, ref($subhdr), $subhdr; $header{NEWTIE} = \%sub; my $newtie = $header{NEWTIE}; my $tieobj = tied %$newtie; # Check class isa_ok( $tieobj, "Astro::FITS::Header"); # Make sure we have a long numification my $tienum = 0 + $tieobj; my $hdrnum = 0 + $subhdr; ok( $tienum > 0); ok( $hdrnum > 0); # Compare memory addresses is( $tienum, $hdrnum, "cf memory addresses" ); printf "# The tied object is: %s\n",0+$tienum; printf "# The original object is:: %s\n",$hdrnum; # test values is($header{NEWTIE}->{VALUE}, $another_card->value); # Test autovivification # Note that $hdr{BLAH}->{YYY} = 5 does not work my $void = $header{BLAH}->{XXX}; printf "# VOID is %s\n", defined $void ? $void : '(undef)'; is(ref($header{BLAH}), 'HASH'); $header{BLAH}->{XXX} = 5; is($header{BLAH}->{XXX}, 5); # Test tied array subheader ok(exists $header{SUBHEADERS}, "Does the subheader exist?"); my $subh = $header{SUBHEADERS}; is( ref($subh), "ARRAY", "Do we have a tie?"); is(@$subh, 2, "Got correct number of array subheaders"); is($subh->[1]->{H2AM}, "AM", "array to tied hash"); # make sure we get SUBHEADERS as a valid key my $got; for my $k (keys %header) { $got = 1 if $k eq 'SUBHEADERS'; } ok( $got, "SUBHEADERS appeared in foreach"); my $p = pop( @$subh ); is($p->{H2AM}, "AM", "pop?"); # push it back on the front unshift( @$subh, $p); is($subh->[0]->{H2AM}, "AM", "unshift?"); # shift it off my $s = shift( @$subh ); is($s->{H2AM}, "AM", "shift?"); # and push it on the end push(@$subh, $s); is($subh->[1]->{H2AM}, "AM", "push?"); # Now remove the subhdrs using the tie @$subh = (); # store the subheader from the earlier item $subh->[2] = $header{BLAH}; is($subh->[2]->{XXX}, 5); # Store a hash $subh->[3] = { AAA => "22"}; is($subh->[3]->{AAA}, 22); # Clear using the objecy @{ $hdr->subhdrs } = (); ok(!exists $header{SUBHEADERS}, "Subheader should not exist"); # make sure we do not get SUBHEADERS as a valid key $got = 0; for my $k (keys %header) { $got = 1 if $k eq 'SUBHEADERS'; } ok( !$got, "SUBHEADERS should not appear in foreach"); Astro-FITS-Header-3.08/t/test.gsd000444004077000012 5600014014777770 16150 0ustar00gbellstaff000000000000A,ZJCMT 8C1TEL  ,C1PID  ,C1OBS   ,C1ONA1  0,C1ONA2  @,C1SNA1  P,C1SNA2  `,C4CSC  p,C4CECO  ,C4EPT  ,C4MCF  ,C4EPH YEAR ,C4ERA DEGREE ,C4EDEC DEGREE ,C4RADATE DEGREE ,C4DECDATE DEGREE ,C4RA2000 DEGREE ,C4EDEC2000 DEGREE ,C4GL DEGREE ,C4GB DEGREE ,C4AZ DEGREE ,C4EL DEGREE ,C4LSC  ,C6FC  ,C4ODCO  -C6DX ARCSEC -C6DY ARCSEC -C6MSA DEGREE !-CELL_V2Y DEGREE )-C4AXY DEGREE 1-C4SX  9-C4SY  A-C4RX  I-C4RY  Q-C1HGT KM Y-C1LONG DEGREE a-C1LAT DEGREE i-C1SNO  q-C6ST  y-C1RCV  -C1FTYP  -C1BKE  -C1BTYP  -C3DAT YYYY.MMDD -C3UT HOUR -C3UT1C DAY -C3LST HOUR -C3CAL  -C3CEN  -C3FLY  -C3FOCUS  -C3MAP  -C3NPP  -C3NMAP  -C6XNP RUNS -C6YNP RUNS -C6XGC RUNS -C6YGC RUNS .C6REV  .C6SD  .C6XPOS  .C6YPOS  .C3NIS  .C3NSAMPLE .C3NO_SCAN_VARS1 !.C3NO_SCAN_VARS2 %.C3SRT SECOND ).C3MXP  -.C3NCI  1.C3NCYCLE  5.C3CL SECOND 9.C3NCP  =.C6NP  A.C3NSV  E.C3PPC  I.C5AT DEG C M.C5PRS MM HG U.C5RH % ].C4AZERR ARCSEC e.C4ELERR ARCSEC m.UAZ ARCSEC u.UEL ARCSEC }.C7SZVRAD NUMBER .C8AAE % .C8ABE % .C8GN  .C8EL  .C8EF  .C4SM  .C4FUN  .C4FRQ HZ .C4SMCO  .C4THROW ARCSEC .C4POSANG DEGREE .C4OFFS_EW ARCSEC .C4OFFS_NS ARCSEC .C4X MM .C4Y MM .C4Z MM .C4EW_SCALE ARCSEC/ENC .C4NS_SCALE ARCSEC/ENC .C4EW_ENCODER ENCODER .C4NS_ENCODER ENCODER .C2FV MM /C2FL MM /C2FR MM  /C4MOCO  /C3NFOC  /C7VR KM/SEC "/C12TCOLD K */C12TAMB K ./C12VDEF  2/C12VREF  B/C3NRC  R/C3NCH  V/C3NRS  Z/C7BCV DN ^/C12CAL  b/C6MODE  r/C12CALTASK /C12CALTYPE /C12REDMODE /C3NOIFPBES /C3CONFIGNR /C3DASOUTPUT /C3DASCALSRC /C3DASSHFTFRAC /C7TAU225  /C7TAURMS  /C7TAUTIME /C7SEEING  /C7SEETIME /C3POLARITY  0C3SBMODE  0C7VRADIAL *0SC12SCAN_VARS1 1 AC12SCAN_VARS2 1 BC12SCAN_TABLE_1 1A?C12SCAN_TABLE_2 1B?C14PHIST RUNS 156C11VD  20J6C11PHA  22JKC12CM  J2@tKC12BM  2@tKC3OVERLAP 2@tKC3MIXNUM   3@tKC3BESCONN J3@tKC3BEINCON 3 rKC3LSPC  3@tKC3BESSPEC 3@tKC12CF GHZ *4tKC12RF GHZ 4tKC3BEFENULO *5tKC3BETOTIF 5tKC3BEFESB  *6@tKC12INFREQ GHZ j6@rKC12FR MHZ 6@tKC12BW MHZ 6@tKC12RT K *7@tKC12SST K j7@t?C12TSKY K 7@t?C12TTEL K 7@t?C12GAINS K/V *8@t?C12CT K j8@t?C12WO NEPER 8@t?C12ETASKY 8@t?C12ALPHA  *9@t?C12GS  j9@t?C12ETATEL 9@t?C12TSKYIM 9@t?C12ETASKYIM *:@t?C12TSYSIM j:@t?C12TASKY  :@t?C3INTT  :??C13DAT  : s?DJCMT m00bi05 LISENFORD IMC JCH IMC RB BESSELIAN EDU}T*C p=ףDKR/C[D́NˊCqG D`{$C>WnNB qCk ѯjiRB RASTER @@AmDztju>tjuxBqA^xBA([LST AIRMASS SCAN_TIME NO_CYCLES A@E2aEpBBEAM WEIGHT TIME @@@@BBBBBBBBBBBBBBBBDK7DCD~0PиD6 \ވDiXD*u(D^9 DHnDK7DCD~0PиD6 \ވDiXD*u(D^9 DHnDN;DN;DN;DN;DN;DN;DN;DN;DN;DN;DN;DN;DN;DN;DN;DN;D1T\D1T\D1T\D1T\D1T\D1T\D1T\D1T\D1T\D1T\D1T\D1T\D1T\D1T\D1T\D1T\fAp=mAtA|AQA @AA33@AGfAp=mAtA|AQA @AA33@AG@@@@@@@@@@@@@@@@@@ D D D D D D D D D D D D D D D DEEDDdD2DODDȏEeDQDQDDD7DDwFF FƽF+EeEmERmo=<%K]"̆?1ncœ>|u?&`?IUr?*7? !?ˑ f?tɾ*hh??>|= _EA&?$>/k>m +>*=D?cW>>?a׾d;^NE>"6:/k?5p@.4M;'?&7O_?Ŀ7]@>5?B2=KS?v?'@oو־]>G&s? >.!q> >?$D?%ճ3 ?ni=|D>;Mx^ՑuVT>@Kg-;>DQӍ&=?ݽ?D>B-3ű!F?>KHGb=fP?$ݿ>J>?)>3>H7fc*k?$,>'>>'J=ܾ=>l\m?ٿ?h-iE=ݾV> 0п}|< F?? ?6nЋa;49|5+!?#*>Y0VRg?>I}'=='$>TL>* y?˽G>ޙG=B2>Q^>>2=m?-S?@>6$?~>] CX=Kyy{Y_=u> E=w %?]d??&j>PG@A(>oj }՜>rh>MV/ PV؈?fO?->=Wq$a#L{ފ4<?>U`W?{[ Wf>>^K\O?נ&={>+*1ZAԾ`[>?c?*7?>?t=틿6Od>Z?G>>,>=Hy>"= E?ս>U^R>zm?*Dد?g ?~&?Nh?;90^$>g)>4?!<):F%>i!,>?4vQ1ge?~o>6b(?XZ>]!R>̼o;)>>dY(a P$>&fŀ= ?/HVF˷>I= P~>Y"?ߕ>|U?y>>d}Ud?}Bh>a=Lڼ:ɞ>E>`>E.?v~>'"|m? z?EG>ҲmR.@C >4?F?&c ?+;T-<x_ϯh[v.>C=Z?>Ҡ1{S??)wx>=O_?~>->5=s^:;=%j#1?!0Q%7{/W?W>Τ?;x/DF8N< Q>EoI 28?nPfQ>I>N?- >$>@>=ߑ^;Nxs@l1&Io¼(w^+пL/?>Bv>~a>"?1 .?[޾Na>w%=G&,:?>Yš>N?q?JU?A?#>A&>њ?>'>.>~&zC*?GzA{?=zMI> v5S+=o?Θ>ُJ{*C???!>m@L>p>w>c&?#K%?>v?]bSq7?U޽ ",>id4ԇU=\><9@Gx>{@0sPھ}>|L7(F)ni>zM?Ud=wm> q{w[޾ԙ=н@ J?\>#>a޽0 O%JX̟>x=&&?kT>Sg=h?Е>X8?ſ)(0F:AG<V.XSgC%GT5t>, 3G?dK`>*?b~Ux>i?=|t)>U=f>e>7>nU>V>wQ=3v ? Z ?;h.UF>C6F=qp?!*<>ɥN?E>=7=,/Ŋ?T>/~>g"ξꩾz^=N} XCpk=w ?l?Y ?C'%>3ҧ> a>OW6]x>i?j>a>䘾K>J>08A~8?XW>_`X<?辠D9ͼyƳ>@"龡Rݽd3?W<[>(?.>o.bƕZ*?T ?;b ?> ⁾g?Z[=>4)>0e? %@VbAq-G<2B\#@שBt>Wȿ$>+;?bC["?^ľa?2=cCKm>kj?~>9?᰿FE+;m ë>F^3Ք>Ǿ$#?$z>w߾>6}佽wֽ)[l6>m~t>q/vD?<9=|`-?ؽ Lp>v>'~> oo> &>Rct>wz뾀>e>W?r=Vkq>L%\mH> ??>;>ь=2>?wkuY'?L!">?:Q?')?GQ ?:>F&sɾgCxJ>l>;(/)[=X=Z] >%?b>؛&U>+>ݥ҉i'U? ? ??\S O쇘>) {r=>$Y>3>Ȭ>9 ]Y׽>5zA^>>/*>穂>6?-2j>[F>I>$BEm)\.?>>>v>$=KaU=[?㾰t>-(n>5 >>,>NU>AO=JvO?7?oc1T<ܾ66?,4'C)7>Z>yyPקs{t> ?>h?~y=>?)10U=o BJ׽Y<=?>Ms{>">ڀj>$?*H W /#hr.:L$?>͵Q?k)@bX@BlA;G<GbeB@,ޒ>f))\՘H?`?V¿oK=J? ?o>J>hVFPN?8=%~>vɿ><ξ1/ݓ>?AҾ7رk?[י=7>Tb~=G[PɾN ?AӔ>;|->?D *?A^>E9 ?o↿u ?;?|"?=:?>?<ȏ=˜==6?ʽD? ?)R [e.t?{8LaDLe LZ>1 dg)C) ?n`*=Ib>_ˤ8!>\Lvn"@ U?~ؾu>A\>%,h=u>2??_Q\?:X,f|=FD->"鴾i3=9V>Ր[-?q?@5b@2WӬ%{FG<G< ? Aϯ??< '>K?I=;D[34Z?G?f=IE>w:I?quŋ־KP돟׻V~s>%>x>zF>e=?# @&>>a6r?M>d-?r=WP )u?2)Kl{?aC)?~= P|m3=NE0>Ͼ ^V>qPNؿon?V?V=F>kC?=7]&ٿfb?nqm>-ϚYeg=JД>?O>d(V?­>L?..ߵ=a0O#f-c=(0>>Lо)=?:?=}`B֪pz>Վ=㾉=򈿼x >Y ?Iezu?,$>5>Կ@ L~A[~Amƾ< ;r}r>;vLjT ?luާ?q/$/& ɡ"bȾ>FQ׾V(>U?$>>\e? 2} X>4g.?G.>|Ҿ)T'S>g?m?S/>n>T?_3'/>Nʽy+)Ѿiɾ\Gj~_j$ =[z> b=np"q>c=?Z>ЋU>[2VϮ>3&+?)S p^=F7!2.?R`V?O<l>z>n=?u? Z ?>ʞܷ:>= 6Z%T>c!gE?cD==Ee>+{?=)"?T m>Q茾vp'?<设|0d>7>avž >#k zL>1^ qmTS?tF?n>pA?h8b-J?>iĞ|4^?J+"i־0 ?!:?^7'>EPj½7ξ d&>%,>>,?,K= *4Q\j?d? c?O5?Z~.WR>}H*2 ?;6.  +>t=Hje>3b65}P>z<s>XLk]>9?ץ?C3c>?&>r=@TZ`ֽ5?\X`ܼZNN=yzX>9)g=]+ = R[QQ=?lL>ʾMezx Cξr?1n?vLɾ0?~Al?<~>7T>t?K9W>8@-?l>⁁q?Eb;>9qA9ABꩾ4E>Gs>> ?oU?>=j?~>n:*> ?V )4=fL>$<< J=+/?e>.<Ypߜ>>G胾Hi.?oUe=rJlx>բ<[4?>"$us3?v4?;K@u0Q=pV/ŽLDQT>T>v^>۠E#J)?xr\SY&9Ӿ--PE:w=-[D>f9GY>>P>7>M4BkԽ >g/<)BV>W?נQ=M@Zd$>ˋ?Z/(?\ȉs(Gh-G<G<GFcE5(P!>Ծ`Ud q о0>J>S\޴w=C=7>T =?; K?T 9U;f.=5J>2/.о7=y=%?D V*?> 2>0پc"w=R3S?n׾_>rP羏]}D4kw3H@r-2H]}?ܴP1ǼOlj?_-( ?M=U 1>& >J40>D b:D"2}=ڮ?hXU4>#Xn>߱>>;>>4^<&k>>:>=B=$=Eٽ>ҝ?Il?ko>v> ZS=:ܢ>.==u{>ŀ%X3 >i.dG<ƒ?B?@2z?>Ҟ:-&a>~O?`f?0F?I߾a_i?j8>;pܾ9)3= >=vLτ=9>{S>~  =v)B=>jǾľ<n> >4q?{웸>d  %? >l⾽Ρ?T>A\WVZ>f5$"r)?(M7>R&;>kհY= 3m>5׾k>2gN*rnc >-bG>Gƾ)栾,>.DY?$&-m̾Ռ?C> Ы^=D1>=>j ]>^s7N p=Wf-S>5Eо?:ϾH>cpq(6>m :>Š >a& '?GW dBsAP'k@H׿=g186?->j'۾o@Dkvh>R8?MӽkΚ=>Ŷ:>>"à>?n a>8;ͳǽ6aX>,Xv?]9 >iHȾ7>!? ˾1ӆdJU_wAk=` .Df=p e=6É6?{;f>)чL>y˜>z)||>L)7v >b[C>1)>c~V=b > 5->\zq>@0q Qo:3d=ښ>*DhC=)&/>ފ?d}hN?CZ? 'PD:`3k?] D(?=y>1Ձ?{Z < ھOLپS AqL>60?_¾I>O?pQ5ĺ9@L@mB "FAstro-FITS-Header-3.08/t/tied.t000444004077000012 3756014014777770 15616 0ustar00gbellstaff000000000000#!perl # Astro::FITS::Header test harness # strict use strict; #load test use Test::More tests => 297; # load modules use Astro::FITS::Header; use Astro::FITS::Header::Item; # T E S T H A R N E S S -------------------------------------------------- # test the test system ok(1); # read header from DATA block my @raw = ; chomp(@raw); # build header array my $header = new Astro::FITS::Header( Cards => \@raw ); # tie my %keywords; tie %keywords, "Astro::FITS::Header", $header; # fetch my $value = $keywords{"TELESCOP"}; is( "$value", "UKIRT, Mauna Kea, HI"); # store $keywords{"TELESCOP"} = "JCMT, Mauna Kea, HI"; my @values = $header->value("TELESCOP"); is( "$values[0]", "JCMT, Mauna Kea, HI"); # Get the comment, set a new one and retrieve it is($keywords{"TELESCOP_COMMENT"}, "Telescope name"); my $new = "Not a telescope"; $keywords{TELESCOP_COMMENT} = $new; is($keywords{TELESCOP_COMMENT}, $new); # store $keywords{"LIFE"} = 42; my @end = $header->index('END'); my @test = $header->index('LIFE'); is($end[0],125); is($test[0],124); ########## # "Missing" header values # ok( exists( $keywords{"MSBID"} ) ); $value = $keywords{"MSBID"}; is( $value, undef ); $value = $keywords{"MSBID_COMMENT"}; is( "$value", "Unique identifier" ); ok( !exists( $keywords{"CSOTAU"} ) ); $value = $keywords{"CSOTAU"}; is( $value, undef ); $value = $keywords{"CSOTAU_COMMENT"}; is( "$value", " / Tau at 225 GHz from CSO\n" ); ########## # Multiline comments # my $s = "Comment line 1\nComment line 2\nComment line 3"; # Store multiline comment $keywords{"COMMENT"} = $s; # It doesn't make any values @values = $header->value("COMMENT"); is( $values[0], undef); is( $values[1], undef); is( $values[2], undef); # The comments come out correctly in the comment method my @comments = $header->comment("COMMENT"); my @s = split("\n",$s); chomp @s; is( $comments[0], $s[0] ); is( $comments[1], $s[1] ); is( $comments[2], $s[2] ); # The comments come out correctly in the tied method is( $s."\n", $keywords{"COMMENT"} ); ########## # Multiline values $s = "0\n1\n2"; my $sr = [0,1,2]; # Assigning with array ref yields correct string $keywords{"TESTVAL"} = $sr; is( $keywords{"TESTVAL"}, $s ); # ... and also gives the correct values my(@vals) = $header->value("TESTVAL"); is($vals[0], 0); is($vals[1], 1); is($vals[2], 2); # ... and also acts correctly in arithmetic expressions { no warnings; is( $keywords{"TESTVAL"} + 1, 1 ); } # ... and also truncates OK $keywords{"TESTVAL"}++; is($keywords{"TESTVAL"}, 1); ############################## # delete delete $keywords{"LIFE"}; my @item = $header->itembyname("LIFE"); unless (defined($item[0])) { ok(1) } else { ok(0) }; # exists ok(exists $keywords{"SIMPLE"}); ok(!exists $keywords{"ARGH"}); ok(!exists $keywords{"LIFE"}); # firstkey, nextkey my $line = 0; my $key; foreach $key (keys %keywords) { my @values = $header->value($key); is($header->keyword($line),$key); if($key ne 'COMMENT') { # Skip [multiline] comments... # END card is a special case -- should return ' ' if($key eq 'END') { is(' ',$keywords{$key}); } else { is($values[0],$keywords{$key}); } } do { $line += 1; } until(($header->keyword($line)||'') ne 'COMMENT' || $key ne 'COMMENT'); } # Test array ref return my $hdr = tied %keywords; # First get the string my $str = $keywords{COMMENT}; ok(not ref $str ); # Then the array $hdr->tiereturnsref(1); my $strref = $keywords{COMMENT}; is(ref($strref), "ARRAY"); my @strings = @$strref; is(scalar(@strings), 3); # There are 4 comments is(join('',@strings), $str); $hdr->tiereturnsref(0); # Test that we can copy in a new hash # This test will fail in v2.4 of Astro::FITS::Header my $href = \%keywords; %{ $href } = ( TELESCOP => 'GEMINI', instrume => 'MICHELLE' ); is($href->{TELESCOP}, 'GEMINI'); is($href->{INSTRUME}, 'MICHELLE'); # Test that SIMPLE and END get put at the beginning and end, respectively is($href->{SIMPLE},undef); is($href->{END},undef); $keywords{SIMPLE} = 0; $keywords{END} = "Drop this string on the floor"; my @keys = keys %keywords; is($keys[0],'SIMPLE'); is($keys[3],'END'); is($keywords{SIMPLE},0); is($keywords{END},' '); #clear undef %keywords; is($header->keyword(0),undef); # Test the override my %keywords2; my $header2 = new Astro::FITS::Header( Cards => \@raw ); tie %keywords2, "Astro::FITS::Header", $header2, tiereturnsref => 1; my $value2 = $keywords2{COMMENT}; is(ref $value2, "ARRAY"); # Test comment parsing in keyword setting $href->{NUM} = "3 / test"; is($href->{NUM},3, "Test value from auto-parse"); is($href->{NUM_COMMENT},'test', "Test comment from auto-parse"); $href->{SLASHSTR} = "foo\\/bar / value is 'foo/bar'"; is($href->{SLASHSTR},'foo/bar', "Test value from complex auto-parse"); is($href->{SLASHSTR_COMMENT},'value is \'foo/bar\'', "Test comment from complex auto-parse"); # test HISTORY handling $keywords{HISTORY} = "foo"; $keywords{HISTORY} .= "bar"; ok($keywords{HISTORY} eq <new(Cards => [ 'KEY1 = 1 / Example header ', 'KEY2 = 2 / Example header ', ])->merge_primary(Astro::FITS::Header->new(Cards => [ 'KEY1 = 1 / Example header ', 'KEY2 = 3 / Example header ', ])); $header3->subhdrs(@diff3); tie my %keywords3, 'Astro::FITS::Header', $header3, tiereturnsref => 1; is_deeply(\%keywords3, { 'KEY1' => '1', 'SUBHEADERS' => [{'KEY2' => '2'}, {'KEY2' => '3'}], }, 'Tied hash with subheaders'); %keywords3 = (); is_deeply(\%keywords3, {}, 'Cleared tied hash is empty'); $keywords3{'KEY3'} = 4; is_deeply(\%keywords3, { 'KEY3' => 4, }, 'Cleared tied hash with new key'); # principal of least surprise.... you should get back what you put in! #$href->{REVERSE} = "foo / bar"; #is($href->{REVERSE}, "foo / bar"); exit; __DATA__ SIMPLE = T / file does conform to FITS standard BITPIX = -32 / number of bits per data pixel NAXIS = 3 / number of data axes NAXIS1 = 25 / length of data axis 1 NAXIS2 = 36 / length of data axis 2 NAXIS3 = 252 / length of data axis 3 EXTEND = T / FITS dataset may contain extensions COMMENT FITS (Flexible Image Transport System) format defined in Astronomy and COMMENT Astrophysics Supplement Series v44/p363, v44/p371, v73/p359, v73/p365. COMMENT Contact the NASA Science Office of Standards and Technology for the COMMENT FITS Definition document #100 and other FITS information. CRVAL1 = -0.07249999791383749 / Axis 1 reference value CRPIX1 = 12.5 / Axis 1 pixel value CTYPE1 = 'a1 ' / LINEAR CRVAL2 = -0.07249999791383743 / Axis 2 reference value CRPIX2 = 18.0 / Axis 2 pixel value CTYPE2 = 'a2 ' / LINEAR CRVAL3 = 1.27557086671004E-6 / Axis 3 reference value CRPIX3 = 126.0 / Axis 3 pixel value CTYPE3 = 'a3 ' / LAMBDA OBJECT = 'galaxy ' / Title of the dataset DATE = '2000-12-13T22:44:53' / file creation date (YYYY-MM-DDThh:mm:ss UTC) ORIGIN = 'NOAO-IRAF FITS Image Kernel July 1999' / FITS file originator BSCALE = 1.0 / True_value = BSCALE * FITS_value + BZERO BZERO = 0.0 / True_value = BSCALE * FITS_value + BZERO HDUCLAS1= 'NDF ' / Starlink NDF (hierarchical n-dim format) HDUCLAS2= 'DATA ' / Array component subclass IRAF-TLM= '23:07:26 (27/02/2000)' / Time of last modification TELESCOP= 'UKIRT, Mauna Kea, HI' / Telescope name INSTRUME= 'CGS4 ' / Instrument OBSERVER= 'SMIRF ' / Observer name(s) OBSREF = '? ' / Observer reference DETECTOR= 'fpa046 ' / Detector array used OBSTYPE = 'OBJECT ' / Type of observation INTTYPE = 'STARE+NDR' / Type of integration MODE = 'ND_STARE' / Observing mode GRPNUM = 0 / Number of observation group RUN = 54 / Number of run EXPOSED = 180 / Total exposure time for integration OBJCLASS= 0 / Class of observed object CD1_1 = 0.144999980926513672 / Axis rotation and scaling matrix CD1_2 = 0.0 / Axis rotation and scaling matrix CD1_3 = 0.0 / Axis rotation and scaling matrix CD2_1 = 0.0 / Axis rotation and scaling matrix CD2_2 = 0.144999980926513672 / Axis rotation and scaling matrix CD2_3 = 0.0 / Axis rotation and scaling matrix CD3_1 = 0.0 / Axis rotation and scaling matrix CD3_2 = 0.0 / Axis rotation and scaling matrix CD3_3 = 2.07933226192836E-10 / Axis rotation and scaling matrix MEANRA = 10.34629999999999939 / Object RA at equinox (hrs) MEANDEC = 20.1186000000000007 / Object Dec at equinox (deg) RABASE = 10.34629999999999939 / Offset zero-point RA at equinox (hrs) DECBASE = 20.1186000000000007 / Offset zero-point Dec at equinox (deg) RAOFF = 0 / Offset RA at equinox (arcsec) DECOFF = 0 / Offset Dec at equinox (arcsec) DROWS = 178 / No of det. in readout row DCOLUMNS= 256 / No of det. in readout column DEPERDN = 6 / Electrons per data number CLOCK0 = -6.20000000000000018 / ALICE CLOCK0 voltage CLOCK1 = -3 / ALICE CLOCK1 voltage CLOCK2 = -7.5 / ALICE CLOCK2 voltage CLOCK3 = -2.79999999999999982 / ALICE CLOCK3 voltage CLOCK4 = -6 / ALICE CLOCK4 voltage CLOCK5 = -2 / ALICE CLOCK5 voltage CLOCK6 = -7.5 / ALICE CLOCK6 voltage VSLEW = 4 / ALICE VSLEW voltage VDET = -3.02000000000000002 / ALICE VDET voltage DET_BIAS= 0.57999999999999996 / ALICE DET_BIAS voltage VDDUC = -3.60000000000000009 / ALICE VDDUC voltage VDETGATE= -4.5 / ALICE VDETGATE voltage VGG_A = -1.60000000000000009 / ALICE VGG_ACTIVE voltage VGG_INA = -1.30000000000000004 / ALICE VGG_INACTIVE voltage VDDOUT = -1 / ALICE VDDOUT voltage V3 = -2.79999999999999982 / ALICE V3 voltage VLCLR = -3 / ALICE VLCLR voltage VLD_A = 4 / ALICE VLOAD_ACTIVE voltage VLD_INA = 4 / ALICE VLOAD_INACTIVE voltage WFREQ = 1 / ALICE waveform state freq. (MHz) RESET_DL= 0.200000000000000011 / NDR reset delay (seconds) CHOP_DEL= 0.029999998999999999 / Chop delay (seconds) READ_INT= 5 / NDR read interval (seconds) NEXP_PH = 0 / Exposures in each chop phase DEXPTIME= 180 / Exposure time (seconds) RDOUT_X1= 1 / Start column of array readout RDOUT_X2= 256 / End column of array readout RDOUT_Y1= 45 / Start row of array readout RDOUT_Y2= 222 / End row of array readout CHOPDIFF= T / Main-offset beam value stored IF_SHARP= F / Shift & add disabled LINEAR = F / Linearisation disabled FILTER = 'B1 ' / Combined filter name FILTERS = 'B1 ' / Combined filter name DETINCR = 1 / Increment (pixels) betw scan positions DETNINCR= 2 / Number of scan positions in scan WPLANGLE= 0 / IRPOL waveplate angle SANGLE = -2.19303900000000018 / Angle of slit SLIT = '0ew ' / Name of slit SLENGTH = 18 / Length of slit SWIDTH = 4 / Width of slit DENCBASE= 800 / Zeropoint (steps) of detector translation DFOCUS = 1.819309999999999983 / Detector focus position GRATING = '150_lpmm' / Name of grating GLAMBDA = 1.274947000000000052 / Grating wavelength GANGLE = 17.09262000000000015 / Grating wavelength GORDER = 3 / Grating order GDISP = 0.00020796522 / Grating dispersion CNFINDEX= 75488 / Index increments when h/w config changes CVF = 'open ' / Name of CVF CLAMBDA = 0 / CVF wavelength IRTANGLE= 6.396519999999999762 / Image rotator angle LAMP = 'off ' / Name of calibration lamp BBTEMP = 0 / Black body temperature CALAPER = 0 / Aperture of tungsten-halogen lamp (%) THLEVEL = 0 / Level of tungsten-halogen lamp IDATE = 19980217 / Date as integer OBSNUM = 54 / Number of observation NEXP = 1 / Exposures in integration AMSTART = 1.334643999999999942 / Airmass at start of obs AMEND = 1.320149999999999935 / Airmass at end of obs RUTSTART= 8.000171999999999173 / Start time of obs (hrs) RUTEND = 8.101883000000000834 / End time of obs (hrs) NBADPIX = 32 MSBID = / Unique identifier CSOTAU / Tau at 225 GHz from CSO END