Index: /branches/ccl_branches/ipponly-20191108/DataStore/Build.PL =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/Build.PL (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/Build.PL (revision 41110) @@ -0,0 +1,41 @@ +use Module::Build; +# See perldoc Module::Build for details of how this works + +Module::Build->new( + module_name => 'DataStore', + dist_version_from => 'lib/DataStore.pm', + author => 'Joshua Hoblitt ', + license => 'gpl', + create_makefile_pl => 'passthrough', + requires => { + 'Carp' => 0, + 'Data::Validate::URI' => '0.01', + 'Digest::MD5::File' => '0.03', + 'IPC::Cmd' => '0.36', + 'File::Basename' => 0, + 'File::Temp' => '0.16', + 'File::Path' => 0, + 'File::stat' => 0, + 'LWP::UserAgent' => 0, + 'Params::Validate' => '0.77', + 'YAML' => '0.58', + }, + build_requires => { + 'CGI' => '3', + 'Net::HTTPServer' => '1.1.1', + 'Test::Cmd' => '1.05', + 'Test::More' => 0, + 'Test::Warn' => '0.08', + }, + recommends => { + 'Test::Distribution' => '1.22', + }, + script_files => [qw( + scripts/dsget + scripts/dsgetfileset + scripts/dsproductls + scripts/dsleech + scripts/dsfilesetls + scripts/dsrootls + )], +)->create_build_script; Index: /branches/ccl_branches/ipponly-20191108/DataStore/Changes =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/Changes (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/Changes (revision 41110) @@ -0,0 +1,60 @@ +Revision history for Perl module DataStore + +0.08 + - add --copies option to dsget + - have dsget set "user.copies" xattr on files downloaded into Nebulous + - change dsget to flush() & sync() downloaded files + - change ds*ls utilties to always return the HTTP status code - 300 as the + exit status + - add --xattr flag to dsget + +0.07 Mon May 12 12:04:24 HST 2008 + - add --timeout option to all ds*ls utilties and other minor doc changes + - add the ability to all DataStore::* classes that handle HTTP to pass + options directly to LWP::UserAgent + - add support for checksumming compressed fits files + - Change DateStore::File to handle passing args to LWP::UserAgent + - change dsget to return the HTTP status code on failure + - remove use of parse_neb_key() from dsget + - dsget doc updates + - fix error reporting bug is dsfilesetls + - change dsget to overwrite existing Nebulous keys + - trap exceptions from DateStore::File::Parse in DataStore::FileSet being + caused by empty file lists + +0.06 Thu Feb 1 13:57:56 HST 2007 + - fix dsleech to handle valid but empty filesets + - change dsfilesetls to output "extra" fields + - add --overwrite option to dsleech + - distcheck fixes + +0.05 Fri Sep 1 11:28:13 HST 2006 + - add --recall, --remember, & rcfile support to dsleech + - add a dep on YAML 0.58 + +0.04 Thu Aug 31 13:01:59 HST 2006 + - allow upper & lower case characters in DataStore fields + - change from lower to upper case all fileset types + - change DataStore::File to always return a DataStore::Response (even when + there is a problem with the retrieved file) + - add dsleech script + +0.03 Wed Aug 30 12:46:00 HST 2006 + - fix a bug in dsproductls where ->status was being called on a + DataStore::Response instead of ->status_line + - Added a Root object and associated Product::Parser to query the root of + the datastore. + - The 'is_success' field in a Response now gets its value carried over from + the HTTP::Response as intended. + - The 'data' field in a Response can now be undef to indicate that no + records were parsed. + - Root::request, Product::request, FileSet::request now always return a + Response object. + - FileSets and Files will now have any additional non-standard fields + parsed into the @extra array. + - Updated tests. + +0.01 Thu Feb 23 13:55:57 2006 + - original version; created by ExtUtils::ModuleMaker 0.44 + + Index: /branches/ccl_branches/ipponly-20191108/DataStore/LICENSE =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/LICENSE (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/LICENSE (revision 41110) @@ -0,0 +1,260 @@ +The General Public License (GPL) +Version 2, June 1991 + +Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, +Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute +verbatim copies of this license document, but changing it is not allowed. + +Preamble + +The licenses for most software are designed to take away your freedom to share +and change it. By contrast, the GNU General Public License is intended to +guarantee your freedom to share and change free software--to make sure the +software is free for all its users. This General Public License applies to most of +the Free Software Foundation's software and to any other program whose +authors commit to using it. (Some other Free Software Foundation software is +covered by the GNU Library General Public License instead.) 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 this service 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 make restrictions that forbid anyone to deny +you these rights or to ask you to surrender the rights. These restrictions +translate to certain responsibilities for you if you distribute copies of the +software, or if you modify it. + +For example, if you distribute copies of such a program, whether gratis or for a +fee, you must give the recipients all the rights that you have. 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. + +We protect your rights with two steps: (1) copyright the software, and (2) offer +you this license which gives you legal permission to copy, distribute and/or +modify the software. + +Also, for each author's protection and ours, we want to make certain that +everyone understands that there is no warranty for this free software. If the +software is modified by someone else and passed on, we want its recipients to +know that what they have is not the original, so that any problems introduced by +others will not reflect on the original authors' reputations. + +Finally, any free program is threatened constantly by software patents. We wish +to avoid the danger that redistributors of a free program will individually obtain +patent licenses, in effect making the program proprietary. To prevent this, we +have made it clear that any patent must be licensed for everyone's free use or +not licensed at all. + +The precise terms and conditions for copying, distribution and modification +follow. + +GNU GENERAL PUBLIC LICENSE +TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND +MODIFICATION + +0. This License applies to any program or other work which contains a notice +placed by the copyright holder saying it may be distributed under the terms of +this General Public License. The "Program", below, refers to any such program +or work, and a "work based on the Program" means either the Program or any +derivative work under copyright law: that is to say, a work containing the +Program or a portion of it, either verbatim or with modifications and/or translated +into another language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not covered by +this License; they are outside its scope. The act of running the Program is not +restricted, and the output from the Program is covered only if its contents +constitute a work based on the Program (independent of having been made by +running the Program). Whether that is true depends on what the Program does. + +1. You may copy and distribute 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 and disclaimer of warranty; +keep intact all the notices that refer to this License and to the absence of any +warranty; and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and you may at +your option offer warranty protection in exchange for a fee. + +2. You may modify your copy or copies of the Program or any portion of it, thus +forming a work based on the Program, and copy and distribute such +modifications or work under the terms of Section 1 above, provided that you also +meet all of these conditions: + +a) You must cause the modified files to carry prominent notices stating that you +changed the files and the date of any change. + +b) You must cause any work that you distribute or publish, that in whole or in +part contains or is derived from the Program or any part thereof, to be licensed +as a whole at no charge to all third parties under the terms of this License. + +c) If the modified program normally reads commands interactively when run, you +must cause it, when started running for such interactive use in the most ordinary +way, to print or display an announcement including an appropriate copyright +notice and a notice that there is no warranty (or else, saying that you provide a +warranty) and that users may redistribute the program under these conditions, +and telling the user how to view a copy of this License. (Exception: if the +Program itself is interactive but does not normally print such an announcement, +your work based on the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If identifiable +sections of that work are not derived from the Program, and can be reasonably +considered independent and separate works in themselves, then this License, +and its terms, do not apply to those sections when you distribute them as +separate works. But when you distribute the same sections as part of a whole +which is a work based on the Program, the distribution of the whole must be on +the terms of this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest your rights to +work written entirely by you; rather, the intent is to exercise the right to control +the distribution of derivative or collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program with the +Program (or with a work based on the Program) on a volume of a storage or +distribution medium does not bring the other work under the scope of this +License. + +3. You may copy and distribute the Program (or a work based on it, under +Section 2) in object code or executable form under the terms of Sections 1 and 2 +above provided that you also do one of the following: + +a) Accompany it with the complete corresponding machine-readable source +code, which must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange; or, + +b) Accompany it with a written offer, valid for at least three years, to give any +third party, for a charge no more than your cost of physically performing source +distribution, a complete machine-readable copy of the corresponding source +code, to be distributed under the terms of Sections 1 and 2 above on a medium +customarily used for software interchange; or, + +c) Accompany it with the information you received as to the offer to distribute +corresponding source code. (This alternative is allowed only for noncommercial +distribution and only if you received the program in object code or executable +form with such an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for making +modifications to it. For an executable work, complete source code means all the +source code for all modules it contains, plus any associated interface definition +files, plus the scripts used to control compilation and installation of the +executable. However, as a special exception, the source code distributed need +not include anything that is normally distributed (in either source or binary form) +with the major components (compiler, kernel, and so on) of the operating system +on which the executable runs, unless that component itself accompanies the +executable. + +If distribution of executable or object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the source +code from the same place counts as distribution of the source code, even though +third parties are not compelled to copy the source along with the object code. + +4. You may not copy, modify, sublicense, or distribute the Program except as +expressly provided under this License. Any attempt otherwise to copy, modify, +sublicense or distribute the Program is void, and will automatically terminate +your rights under this License. However, parties who have received copies, or +rights, from you under this License will not have their licenses terminated so long +as such parties remain in full compliance. + +5. You are not required to accept this License, since you have not signed it. +However, nothing else grants you permission to modify or distribute the Program +or its derivative works. These actions are prohibited by law if you do not accept +this License. Therefore, by modifying or distributing the Program (or any work +based on the Program), you indicate your acceptance of this License to do so, +and all its terms and conditions for copying, distributing or modifying the +Program or works based on it. + +6. Each time you redistribute the Program (or any work based on the Program), +the recipient automatically receives a license from the original licensor to copy, +distribute or modify the Program subject to these terms and conditions. You +may not impose any further restrictions on the recipients' exercise of the rights +granted herein. You are not responsible for enforcing compliance by third parties +to this License. + +7. If, as a consequence of a court judgment or allegation of patent infringement +or for any other reason (not limited to patent issues), 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 distribute so as to satisfy simultaneously your obligations +under this License and any other pertinent obligations, then as a consequence +you may not distribute the Program at all. For example, if a patent license would +not permit royalty-free redistribution of the Program by all those who receive +copies directly or indirectly through you, then the only way you could satisfy +both it and this License would be to refrain entirely from distribution of the +Program. + +If any portion of this section is held invalid or unenforceable under any particular +circumstance, the balance of the section is intended to apply and the section as +a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any patents or other +property right claims or to contest validity of any such claims; this section has +the sole purpose of protecting the integrity of the free software distribution +system, which is implemented by public license practices. Many people have +made generous contributions to the wide range of software distributed through +that system in reliance on consistent application of that system; it is up to the +author/donor to decide if he or she is willing to distribute software through any +other system and a licensee cannot impose that choice. + +This section is intended to make thoroughly clear what is believed to be a +consequence of the rest of this License. + +8. If the distribution and/or use of the Program is restricted in certain countries +either by patents or by copyrighted interfaces, the original copyright holder who +places the Program under this License may add an explicit geographical +distribution limitation excluding those countries, so that distribution is permitted +only in or among countries not thus excluded. In such case, this License +incorporates the limitation as if written in the body of this License. + +9. The Free Software Foundation may publish revised and/or new versions of the +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 a +version number of this License which applies to it and "any later version", you +have the option of following the terms and conditions either of that version or of +any later version published by the Free Software Foundation. If the Program does +not specify a version number of this License, you may choose any version ever +published by the Free Software Foundation. + +10. If you wish to incorporate parts of the Program into other free programs +whose distribution conditions are different, write to the author to ask for +permission. For software which is copyrighted by the Free Software Foundation, +write to the Free Software Foundation; we sometimes make exceptions for this. +Our decision will be guided by the two goals of preserving the free status of all +derivatives of our free software and of promoting the sharing and reuse of +software generally. + +NO WARRANTY + +11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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. + +12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED +TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY +WHO MAY MODIFY AND/OR REDISTRIBUTE 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. + +END OF TERMS AND CONDITIONS Index: /branches/ccl_branches/ipponly-20191108/DataStore/MANIFEST =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/MANIFEST (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/MANIFEST (revision 41110) @@ -0,0 +1,39 @@ +Build.PL +Changes +LICENSE +MANIFEST +META.yml +Makefile.PL +README +Todo +lib/DataStore.pm +lib/DataStore/File.pm +lib/DataStore/File/Parser.pm +lib/DataStore/FileSet.pm +lib/DataStore/FileSet/Parser.pm +lib/DataStore/Product.pm +lib/DataStore/Product/Parser.pm +lib/DataStore/Record.pm +lib/DataStore/Response.pm +lib/DataStore/Root.pm +lib/DataStore/Utils.pm +scripts/dsfilesetls +scripts/dsget +scripts/dsleech +scripts/dsproductls +scripts/dsrootls +t/00_distribution.t +t/01_load.t +t/02_fileset_parse.t +t/03_file_parse.t +t/04_record.t +t/05_product.t +t/06_fileset.t +t/07_file.t +t/08_response.t +t/09_datastore.t +t/10_dsget.t +t/11_dsproductls.t +t/12_dsfilesetls.t +t/13_dsrootls.t +t/14_root.t Index: /branches/ccl_branches/ipponly-20191108/DataStore/README =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/README (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/README (revision 41110) @@ -0,0 +1,15 @@ +pod2text DataStore.pm > README + +If this is still here it means the programmer was too lazy to create the readme file. + +You can create it now by using the command shown above from this directory. + +At the very least you should be able to use this set of instructions +to install the module... + +perl Build.PL +./Build +./Build test +./Build install + +If you are on a windows box you should use 'nmake' rather than 'make'. Index: /branches/ccl_branches/ipponly-20191108/DataStore/Todo =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/Todo (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/Todo (revision 41110) @@ -0,0 +1,3 @@ +TODO list for Perl module DataStore + +- Nothing yet Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore.pm (revision 41110) @@ -0,0 +1,159 @@ +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: DataStore.pm,v 1.11 2008-05-13 03:12:52 jhoblitt Exp $ + +package DataStore; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.08'; + +=pod + +=head1 NAME + +DataStore - client interface to a DataStore server + +=head1 SYNOPSIS + + use DataStore; + + # equivalent to: + + use DataStore::File::Parser; + use DataStore::File; + use DataStore::FileSet::Parser; + use DataStore::FileSet; + use DataStore::Product; + use DataStore::Response; + use DataStore::Utils; + +=head1 DESCRIPTION + +This is a convenience module so that that don't have to individualy load (C) all of the common DataStore inteface modules. Please see the POD of the +individual modules for usage information. If this is your browsing of the +documentation you may want to start with L. + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +None. + +=head1 EXAMPLE PROGRAM + + #!/usr/bin/perl + + use strict; + use warnings; + + # loads DataStore::* + use DataStore; + + my $dsp = DataStore::Product->new( + uri => 'http://example.org/productid/', + last_fileset => 'foobarbaz', + ); + + # returns a DataStore::Response object + my $response = $dsp->request; + + unless ($response->is_success) { + die $response->status; + } + + # arrayref of DataStore::FileSet objects + my $filesets = $response->data; + + # the query could be a success but still return no filesets + unless ($filesets) { + warn "no filesets returned"; + exit(0); + } + + # returns a DataStore::Response object + my $response2 = @$filesets[0]->request; + + unless ($response2->is_success) { + die $response2->status; + } + + # arrayref of DataStore::File objects + my $files = $response->data; + + # the query could be a success but still return no files (is that legal?) + unless (@$files) { + warn "no files returned"; + exit(0); + } + + # requires a filename + my $response3 = @$files[0]->request( filename => '/dev/null' ); + unless ($response3->is_success) { + warn $response3->status; + die; + } + + # $response3->data is '/dev/null' + +=cut + +use DataStore::File::Parser; +use DataStore::File; +use DataStore::FileSet::Parser; +use DataStore::FileSet; +use DataStore::Product::Parser; +use DataStore::Product; +use DataStore::Root; +use DataStore::Response; +use DataStore::Utils; + +=head1 CREDITS + +Just me, myself, and I. + +=head1 SUPPORT + +Please contact the author directly via e-mail. + +=head1 AUTHOR + +Joshua Hoblitt + +=head1 COPYRIGHT + +Copyright (C) 2006 Joshua Hoblitt. 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 2 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. + +The full text of the license can be found in the LICENSE file included with +this module, or in the L Pod as supplied with Perl 5.8.1 and later. + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/File.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/File.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/File.pm (revision 41110) @@ -0,0 +1,348 @@ +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: File.pm,v 1.18 2008-05-07 03:05:03 jhoblitt Exp $ + +package DataStore::File; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.03'; + +use base qw( DataStore::Record ); + +use Carp qw( carp ); +use DataStore::Response; +use DataStore::Utils qw( $STD_FIELD $BYTE_FIELD $MD5_FIELD %KNOWN_FILE_TYPES ); +use Digest::MD5::File qw( file_md5_hex ); +use File::Basename qw( basename ); +use File::Temp (); +use File::stat; +use IPC::Cmd 0.36 qw( can_run run ); +use Params::Validate qw( validate SCALAR ARRAYREF UNDEF ); + +use vars qw( @BASE_FIELDS ); + +@BASE_FIELDS = qw( fileid bytes md5sum type extra compressed ); + +__PACKAGE__->mk_accessors(@BASE_FIELDS); + +=pod + +=head1 NAME + +DataStore::File - represents a DataStore File + +=head1 SYNOPSIS + + use DataStore::file; + + my $dsf = DateStore::File->new( + uri => 'http://example.org/foo', + fileid => '12buckelyourshoe', + bytes => 12345, + md5sum => 'fe6a2b6564c0d4cfb3bbf1db813824ba', + type => 'foo', + ); + + my $uri = $dsf->uri; + my fileid = $dsf->fileid; + my $bytes = $dsf-bytes; + my $md5sum = $dsf->md5sum; + my $type = $dsf-type; + my DataStore::Response $response = $dsf->request( filename => "/foo/bar" ); + +=head1 DESCRIPTION + +This class I L + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +=head3 Constructors + +=over 4 + +=item * C + +Basic constructor. + + my $dsf = DateStore::File->new( + uri => 'http://example.org/foo', + fileid => '12buckelyourshoe', + bytes => 12345, + md5sum => 'fe6a2b6564c0d4cfb3bbf1db813824ba', + type => 'foo', + ); + +Accepts a mandatory hash and returns a L object. + +=over 4 + +=item * uri + +A valid I URI as a string. I + +=item * fileid + +The FIle ID as a string. + +This key is optional. + +=item * bytes + +The size of the file as an integer number of bytes. + +This key is optional. + +=item * md5sum + +The hex encoded md5 checksum of the file. + +This key is optional. + +=item * type + +The type of file as a string. + +This key is optional. + +=back + +=cut + +sub new +{ + my $class = shift; + + # validates uri, doesn't check other params + my $self = $class->SUPER::new(@_); + + validate(@_, + { + uri => { + type => SCALAR, + callbacks => { + 'is valid uri filename' => sub { $_[0] !~ m|/$| }, + }, + }, + fileid => { + type => SCALAR, + regex => $STD_FIELD, + optional => 1, + }, + bytes => { + type => SCALAR, + regex => $BYTE_FIELD, + optional => 1, + }, + md5sum => { + type => SCALAR, + regex => $MD5_FIELD, + optional => 1, + }, + type => { + type => SCALAR, + callbacks => { + 'is valid type' => + sub { exists $KNOWN_FILE_TYPES{$_[0]} }, + }, + optional => 1, + }, + extra => { + type => SCALAR | ARRAYREF, + optional => 1, + }, + compressed => { + type => SCALAR | UNDEF, + optional => 1, + }, + }, + ); + + return $self; +} + +=back + +=head3 Object Methods + +=over 4 + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Retrieves and processes the File listing pointed to by the L of this +object. + +XXX writing the file into memory or to a filehandle will be implemented upon +request. + + my $response = $dsf->request( filename => "/foo/bar" ); + +Accepts a mandatory hash and returns a L object. + +=over 4 + +=item * filename + +The filename/path to save the file to disk as. It is the user's responsibility +to make sure that this is a valid filename/path. + +=back + +=cut + +sub request +{ + my $self = shift; + + my %p = validate(@_, + { + filename => { + type => SCALAR, + regex => qr/\S+/, # string with at least 1 non WS char + }, + ua_args => { + optional => 1, + }, + no_proxy => { + type => SCALAR, + optional => 1, + }, + }, + ); + + my $verbose = 0; + + # make request + my $ua; + if (defined $p{ua_args}) { + $ua = LWP::UserAgent->new(%{$p{ua_args}}); + } else { + $ua = LWP::UserAgent->new; + } + + # load proxy environment variables (if any) + if (!$p{no_proxy}) { + $ua->env_proxy; + } + + my $request = HTTP::Request->new(GET => $self->uri); + my $filename = $p{filename}; + my $response = $ua->request($request, $filename); + + if ($response->is_success) { + my $funpack; + if ($self->compressed) { + $funpack = can_run('funpack') + or warn "can't find funpack -- unable to compute checksum"; + } + + my $chk_file = $filename; + # so that the tmp file stays in scope until we're done processing + my $tmp; + if ($funpack) { + $tmp = File::Temp->new( + DIR => '/tmp', + TEMPLATE => basename($filename) . '.XXXXXXXX', + SUFFIX => '.tmp', + UNLINK => 1, + ); + + my $unpacked_path = $tmp->filename; + + my $command = "$funpack -S -C $filename > $unpacked_path"; + my ($success, $status, $full_buf, $stdout_buf, $stderr_buf) + = run(command => $command, verbose => $verbose); + + unless ($success) { + die "funpack returned exit status $status\n"; + } + + $chk_file = $unpacked_path; + } + + # check size + if (defined $self->bytes) { + my $size = stat($chk_file)->size; + if (! ($self->bytes == $size)) { + unlink $filename; + carp "uri: ", $self->uri, + " - expected size: ", $self->bytes, + " got: ", $size; + # set the filename to undef to indicate an error + $filename = undef; + } else { + carp "uri: ", $self->uri, + " - expected size: ", $self->bytes, + " got: ", $size + if $verbose; + } + } + + if (defined $filename and defined $self->md5sum) { + my $md5 = file_md5_hex($chk_file); + if (! ($self->md5sum eq $md5)) { + unlink $filename; + carp "uri: ", $self->uri, + " - expected md5: ", $self->md5sum, + " got: ", $md5; + # set the filename to undef to indicate an error + $filename = undef; + } else { + carp "uri: ", $self->uri, + " - expected md5: ", $self->md5sum, + " got: ", $md5 + if $verbose; + } + } + } + + # return DS::Response object + my $dsr = DataStore::Response->new( + is_success => $response->is_success, + code => $response->code, + status_line => $response->status_line, + data => $filename, + request => $self, + ); +} + +=back + +=head1 SEE ALSO + +L + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/File/Parser.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/File/Parser.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/File/Parser.pm (revision 41110) @@ -0,0 +1,232 @@ +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: Parser.pm,v 1.15 2007-09-26 03:41:00 jhoblitt Exp $ + +package DataStore::File::Parser; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.02'; + +use base qw( Class::Accessor::Fast ); + +use Carp qw( carp ); +use Data::Validate::URI qw( is_uri ); +use DataStore::Utils qw( $STD_FIELD $BYTE_FIELD $MD5_FIELD %KNOWN_FILE_TYPES ); +use DataStore::File; +use Params::Validate qw( validate validate_pos SCALAR ); + +__PACKAGE__->mk_ro_accessors(qw(base_uri)); + +=pod + +=head1 NAME + +DataStore::File::Parser - parses the DataStore 'File' list format + +=head1 SYNOPSIS + + use DataStore::File::Parser; + + my $parser = DataStore::File::Parser->new( + base_uri => 'http://example.org/', + ); + + my @data = $parser->parse($str); + or + my $data = $parser->parse($str); + + +=head1 DESCRIPTION + +This class parses a DataStore listing of Is into an array of L objects. + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +=head3 Constructors + +=over 4 + +=item * C + +Basic constructor. + + my $parser = DataStore::File::Parser->new( + base_uri => 'http://example.org/', + ); + +Accepts an optional hash and returns a L object. + +=over 4 + +=item * base_uri + +The base of the URI to set in the created L objects. + +This key is optional and defaults to C. + +=back + +=cut + +sub new +{ + my $class = shift; + + my %p = validate(@_, + { + base_uri => { + type => SCALAR, + callbacks => { + 'is valid http uri' => + sub { is_uri($_[0]) and $_[0] =~ /^http:/ }, + 'uri ends with /index.txt' => + sub { $_[0] =~ m|/index.txt$| }, + + }, + default => 'http://example.org/index.txt', + }, + }, + ); + + my $self = bless {}, ref $class || $class; + + $p{base_uri} =~ qr|(.*?/)index.txt|; + $self->{base_uri} = $1; + + return $self; +} + + +=back + +=head3 Object Methods + +=over 4 + +=item * C + +Basic accessor. + +=item * C + +Accepts a string and returns a list in list context or an arrayref is scalar +context. An empty list or undef is returned if the string contained no rows. + +=cut + +sub parse +{ + my $self = shift; + + my ($doc) = validate_pos(@_, + { + type => SCALAR, + regex => qr/\S+/, # string with at least 1 non WS char + } + ); + + my @data; + my $lineno = 1; +LINE: foreach my $line (split /\n/, $doc) { + # blank lines + next LINE if $line =~ /^\s*$/; + + # comment lines + next LINE if $line =~ /^\s*\#/; + + my @fields = split /\|/, $line; + + # at least fileid, bytes, md5sum, and type fields are required + if (scalar @fields < 4) { + carp "line $lineno: not enough fields: $line"; + next LINE; + } + + foreach my $field (@fields) { + # fields are not allowed to contain \# + if ($field =~ /\#/) { + carp "line $lineno: field $field: contains #: $line"; + next LINE; + } + + # strip leading and trailing whitespace + $field =~ s/^\s+//; + $field =~ s/\s+$//; + } + + my ($fileid, $bytes, $md5sum, $type) = @fields; + + # validate format of fileid and type + foreach my $field ($fileid, $type) { + unless ($field =~ $STD_FIELD) { + carp "line $lineno: field $field:" + . " does not conform to $STD_FIELD: $line"; + next LINE; + } + } + + # validate format of bytes + unless ($bytes =~ $BYTE_FIELD) { + carp "line $lineno: field $bytes:" + . " does not conform to $BYTE_FIELD: $line"; + next LINE; + } + + # validate format of md5sum, hex encoded + unless ($md5sum =~ $MD5_FIELD) { + # allow md5sum to be empty + unless ($md5sum =~ /^\s*$/) { + carp "line $lineno: field $md5sum:" + . " does not conform to $MD5_FIELD: $line"; + next LINE; + } + $md5sum = undef; + } + + unless (exists $KNOWN_FILE_TYPES{$type}) { + carp "line $lineno: type $type unknown: $line"; + next LINE; + } + + my @extra = @fields[4 .. $#fields] if $#fields >= 4; + + my %p = ( + fileid => $fileid, + bytes => $bytes, + type => $type, + extra => \@extra, + uri => $self->base_uri . $fileid, + ); + $p{md5sum} = $md5sum if $md5sum; + + # fifo + push @data, DataStore::File->new(%p); + } continue { + $lineno++; + } + + return unless @data; + return wantarray ? @data : \@data; +} + +=back + +=head1 SEE ALSO + +L, L + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/FileSet.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/FileSet.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/FileSet.pm (revision 41110) @@ -0,0 +1,253 @@ +# Copyright (C) 2006-2008 Joshua Hoblitt +# +# $Id: FileSet.pm,v 1.15 2008-05-12 22:04:53 jhoblitt Exp $ + +package DataStore::FileSet; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.04'; + +use base qw( DataStore::Record ); + +use Carp qw( carp ); +use DataStore::File::Parser; +use DataStore::Response; +use DataStore::Utils qw( $STD_FIELD $TIME_FIELD %KNOWN_FILESET_TYPES ); +use LWP::UserAgent; +use Params::Validate qw( validate SCALAR ARRAYREF ); + +use vars qw( @BASE_FIELDS ); + +@BASE_FIELDS = qw( fileset datetime type extra ); + +__PACKAGE__->mk_accessors(@BASE_FIELDS); + +=pod + +=head1 NAME + +DataStore::FileSet - represents a DataStore FileSet + +=head1 SYNOPSIS + + use DataStore::FileSet; + + my $dsfs = DateStore::FileSet->new( + uri => 'http://example.org/', + fileset => '12buckelyourshoe', + datetime => '2042-01-01T00:00:00Z', + type => 'foo', + ); + + my $uri = $dsfs->uri; + my $fileset = $dsfs->fileset; + my $datatime = $dsfs->datetime; + my $type = $dsfs->type; + my DataStore::Response $response = $dsfs->request; + +=head1 DESCRIPTION + +This class I L + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +=head3 Constructors + +=over 4 + +=item * C + +Basic constructor. + + my $dsfs = DateStore::FileSet->new( + uri => 'http://example.org/', + fileset => '12buckelyourshoe', + datetime => '2042-01-01T00:00:00Z', + type => 'foo', + ); + +Accepts a mandatory hash and returns a L object. + +=over 4 + +=item * uri + +A valid I URI as a string. I + +=item * fileset + +The FileSet ID as a string. + +This key is optional. + +=item * datetime + +The time and date as a string. + +This key is optional. + +=item * type + +The I of record as a string. + +This key is optional. + +=back + +=cut + +sub new +{ + # turn off param validation as it has been causing problems + local $Params::Validate::NO_VALIDATION = 1; + + my $class = shift; + + # validates uri, doesn't check other params + my $self = $class->SUPER::new(@_); + + validate(@_, + { + uri => { + type => SCALAR, + callbacks => { + 'uri ends with /index.txt' + => sub { $_[0] =~ m|/index.txt$| }, + } + }, + fileset => { + type => SCALAR, + regex => $STD_FIELD, + optional => 1, + }, + datetime => { + type => SCALAR, + regex => $TIME_FIELD, + optional => 1, + }, + type => { + type => SCALAR, + callbacks => { + 'is valid type' => + sub { exists $KNOWN_FILESET_TYPES{$_[0]} }, + }, + optional => 1, + }, + extra => { + type => SCALAR | ARRAYREF, + optional => 1, + }, + }, + ); + + return $self; +} + +=back + +=head3 Object Methods + +=over 4 + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Retrieves and processes the File listing pointed to by the L of this +object. + +Accepts no parameters and returns a L object. + +=cut + +sub request +{ + my $self = shift; + + my %p = validate(@_, + { + ua_args => { + optional => 1, + }, + no_proxy => { + type => SCALAR, + optional => 1, + }, + }, + ); + + # make request + my $ua; + if (defined $p{ua_args}) { + $ua = LWP::UserAgent->new(%{$p{ua_args}}); + } else { + $ua = LWP::UserAgent->new; + } + + if (!$p{no_proxy}) { + # load proxy environment variables (if any) + $ua->env_proxy; + } + + my $request = HTTP::Request->new(GET => $self->uri); + my $response = $ua->request($request); + + my $data; + + if ($response->is_success) { + # parse document + my $parser = DataStore::File::Parser->new(base_uri => $self->uri); + + eval { + $data = $parser->parse($response->content); + }; + if ($@) { + carp "error parsing DataStore File format: $@"; + } + } + + # return DS::Response object + my $dsr = DataStore::Response->new( + is_success => $response->is_success, + code => $response->code, + status_line => $response->status_line, + data => $data, + request => $self, + ); +} + +=back + +=head1 SEE ALSO + +L + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/FileSet/Parser.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/FileSet/Parser.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/FileSet/Parser.pm (revision 41110) @@ -0,0 +1,214 @@ +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: Parser.pm,v 1.17 2007-09-26 00:09:52 jhoblitt Exp $ + +package DataStore::FileSet::Parser; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.02'; + +use base qw( Class::Accessor::Fast ); + +use Carp qw( carp ); +use Data::Validate::URI qw( is_uri ); +use DataStore::FileSet; +use DataStore::Utils qw( $STD_FIELD $TIME_FIELD %KNOWN_FILESET_TYPES ); +use Params::Validate qw( validate validate_pos SCALAR); + +__PACKAGE__->mk_ro_accessors(qw(base_uri)); + +=pod + +=head1 NAME + +DataStore::FileSet::Parser - parses the DataStore 'FileSet' list format + +=head1 SYNOPSIS + + use DataStore::FileSet::Parser; + + my $parser = DataStore::FileSet::Parser->new( + base_uri => 'http://example.org/index.txt', + ); + + my @data = $parser->parse($str); + or + my $data = $parser->parse($str); + +=head1 DESCRIPTION + +This class parses a DataStore listing of Is into an array of L objects. + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +=head3 Constructors + +=over 4 + +=item * C + +Basic constructor. + + my $parser = DataStore::FileSet::Parser->new( + base_uri => 'http://example.org/index.txt', + ); + +Accepts an optional hash and returns a L object. + +=over 4 + +=item * base_uri + +The base of the URI to set in the created L objects. + +This key is optional and defaults to C. + +=back + +=cut + +sub new +{ + my $class = shift; + + my %p = validate(@_, + { + base_uri => { + type => SCALAR, + callbacks => { + 'is valid http uri' => + sub { is_uri($_[0]) and $_[0] =~ /^http:/ }, + 'uri ends with /index.txt' => + sub { $_[0] =~ m|/index.txt$| }, + }, + default => 'http://example.org/index.txt', + }, + }, + ); + + my $self = bless {}, ref $class || $class; + + $p{base_uri} =~ qr|(.*?/)index.txt|; + $self->{base_uri} = $1; + + return $self; +} + +=back + +=head3 Object Methods + +=over 4 + +=item * C + +Basic accessor. + +=item * C + +Accepts a string and returns a list in list context or an arrayref is scalar +context. An empty list or undef is returned if the string contained no rows. + +=cut + +sub parse +{ + my $self = shift; + + my ($doc) = validate_pos(@_, + { + type => SCALAR, + } + ); + + my @data; + my $lineno = 1; +LINE: foreach my $line (split /\n/, $doc) { + # blank lines + next LINE if $line =~ /^\s*$/; + + # comment lines + next LINE if $line =~ /^\s*\#/; + + my @fields = split /\|/, $line; + + # at least fileset, datatime, and type fields are required + if (scalar @fields < 3) { + carp "line $lineno: not enough fields: $line"; + next LINE; + } + + foreach my $field (@fields) { + # fields are not allowed to contain # + if ($field =~ /\#/) { + carp "line $lineno: field $field: contains #: $line"; + next LINE; + } + + # strip leading and trailing whitespace + $field =~ s/^\s+//; + $field =~ s/\s+$//; + } + + my ($fileset, $datetime, $type) = @fields; + + # validate format of fileset and type + foreach my $field ($fileset, $type) { + unless ($field =~ $STD_FIELD) { + carp "line $lineno: field $field:" + . " does not conform to $STD_FIELD: $line"; + next LINE; + } + } + + # validate format of datetime + unless ($datetime =~ $TIME_FIELD) { + carp "line $lineno: field $datetime:" + . " does not conform to $TIME_FIELD"; + next LINE; + } + + unless (exists $KNOWN_FILESET_TYPES{$type}) { + carp "line $lineno: type $type unknown: $line"; + next LINE; + } + + my @extra = @fields[3 .. $#fields] if $#fields >= 3; + + # fifo + push @data, DataStore::FileSet->new({ + fileset => $fileset, + datetime => $datetime, + type => $type, + extra => \@extra, + uri => $self->base_uri . $fileset . '/index.txt', + }); + } continue { + $lineno++; + } + + return unless @data; + return wantarray ? @data : \@data; +} + +=back + +=head1 SEE ALSO + +L, L + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Product.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Product.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Product.pm (revision 41110) @@ -0,0 +1,233 @@ +# Copyright (C) 2006-2008 Joshua Hoblitt +# +# $Id: Product.pm,v 1.11 2008-05-12 22:04:53 jhoblitt Exp $ + +package DataStore::Product; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.02'; + +use base qw( DataStore::Record ); + +use Carp qw( carp ); +use DataStore::FileSet::Parser; +use DataStore::Record; +use DataStore::Response; +use DataStore::Utils qw( $STD_FIELD $TIME_FIELD %KNOWN_PRODUCT_TYPES ); +use LWP::UserAgent; +use Params::Validate qw( validate SCALAR); + +use vars qw( @BASE_FIELDS ); + +@BASE_FIELDS = qw( product last_fileset last_datetime type desc ); + +__PACKAGE__->mk_ro_accessors(@BASE_FIELDS); + +=pod + +=head1 NAME + +DataStore::Product - represents a DataStore Product ID + +=head1 SYNOPSIS + + use DataStore::Product; + + my $dsp = DataStore::Product->new( + uri => 'http://example.com/productid/', + last_fileset => 'foobar', + ); + + my $uri = $dsp->uri; + my $fileset = $dsp_fileset; + my DataStore::Response $response = $dsp->request; + +=head1 DESCRIPTION + +This class I L + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +=head3 Constructors + +=over 4 + +=item * C + +Basic constructor. + + my $dsp = DataStore::Product->new( + uri => 'http://example.com/productid/', + last_fileset => 'foobar', + ); + +Accepts a mandatory hash and returns a L object. + +=over 4 + +=item * uri + +A valid I URI as a string. I + +=item * last_fileset + +The last FileSet ID that was requested as a string. + +This key is optional. + +=back + +=cut + +sub new +{ + my $class = shift; + + # validates uri, doesn't check other params + my $self = $class->SUPER::new(@_); + + validate(@_, + { + uri => { + type => SCALAR, + callbacks => { + 'uri ends with /index.txt' + => sub { $_[0] =~ m|/index.txt$| }, + } + }, + product => { + type => SCALAR, + optional => 1, + }, + last_fileset => { + type => SCALAR, + callbacks => { + 'is valid fileset ID' => sub { $_[0] =~ $STD_FIELD }, + }, + optional => 1, + }, + last_datetime => { + type => SCALAR, + regex => $TIME_FIELD, + optional => 1, + }, + type => { + type => SCALAR, + callbacks => { + 'is valid type' => + sub { exists $KNOWN_PRODUCT_TYPES{$_[0]} }, + }, + optional => 1, + }, + desc => { + type => SCALAR, + optional => 1, + }, + }, + ); + + return $self; +} + +=back + +=head3 Object Methods + +=over 4 + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Retrieves and processes the FileSet listing pointed to by the L of this +object. + +Accepts no parameters and returns a L object. + +=cut + +sub request +{ + my $self = shift; + + my %p = validate(@_, + { + ua_args => { + optional => 1, + }, + no_proxy => { + type => SCALAR, + optional => 1, + }, + }, + ); + + # make request + my $ua; + if (defined $p{ua_args}) { + $ua = LWP::UserAgent->new(%{$p{ua_args}}); + } else { + $ua = LWP::UserAgent->new; + } + + if (!$p{no_proxy}) { + # load proxy environment variables (if any) + $ua->env_proxy; + } + + my $request; + if ($self->last_fileset) { + $request = HTTP::Request->new( + GET => $self->uri . "?" . $self->last_fileset, + ); + } else { + $request = HTTP::Request->new(GET => $self->uri); + } + my $response = $ua->request($request); + + my $data; + + if ($response->is_success) { + # parse document + my $parser = DataStore::FileSet::Parser->new(base_uri => $self->uri); + + $data = $parser->parse($response->content); + } + + # return DS::Response object + my $dsr = DataStore::Response->new( + is_success => $response->is_success, + code => $response->code, + status_line => $response->status_line, + data => $data, + request => $self, + ); +} + +=back + +=head1 SEE ALSO + +L + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Product/Parser.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Product/Parser.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Product/Parser.pm (revision 41110) @@ -0,0 +1,214 @@ +# Adapted from FileSet/Parser.pm +# +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: Parser.pm,v 1.2 2007-09-26 00:13:29 jhoblitt Exp $ + +package DataStore::Product::Parser; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.01'; + +use base qw( Class::Accessor::Fast ); + +use Carp qw( carp ); +use Data::Validate::URI qw( is_uri ); +use DataStore::Product; +use DataStore::Utils qw( $STD_FIELD $TIME_FIELD %KNOWN_PRODUCT_TYPES ); +use Params::Validate qw( validate validate_pos SCALAR); + +__PACKAGE__->mk_ro_accessors(qw(base_uri)); + +=pod + +=head1 NAME + +DataStore::Product::Parser - parses the DataStore 'Product' list format + +=head1 SYNOPSIS + + use DataStore::Product::Parser; + + my $parser = DataStore::Product::Parser->new( + base_uri => 'http://example.org/index.txt', + ); + + my @data = $parser->parse($str); + or + my $data = $parser->parse($str); + +=head1 DESCRIPTION + +This class parses a root DataStore listing into an array of L objects. + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +=head3 Constructors + +=over 4 + +=item * C + +Basic constructor. + + my $parser = DataStore::Product::Parser->new( + base_uri => 'http://example.org/index.txt', + ); + +Accepts an optional hash and returns a L object. + +=over 4 + +=item * base_uri + +The base of the URI to set in the created L objects. + +This key is optional and defaults to C. + +=back + +=cut + +sub new +{ + my $class = shift; + + my %p = validate(@_, + { + base_uri => { + type => SCALAR, + callbacks => { + 'is valid http uri' => + sub { is_uri($_[0]) and $_[0] =~ /^http:/ }, + 'uri ends with /index.txt' => + sub { $_[0] =~ m|/index.txt$| }, + + }, + default => 'http://example.org/index.txt', + }, + }, + ); + + my $self = bless {}, ref $class || $class; + + $p{base_uri} =~ qr|(.*?/)index.txt|; + $self->{base_uri} = $1; + + return $self; +} + +=back + +=head3 Object Methods + +=over 4 + +=item * C + +Basic accessor. + +=item * C + +Accepts a string and returns a list in list context or an arrayref is scalar +context. An empty list or undef is returned if the string contained no rows. + +=cut + +sub parse +{ + my $self = shift; + + my ($doc) = validate_pos(@_, + { + type => SCALAR, + } + ); + + my @data; + my $lineno = 1; +LINE: foreach my $line (split /\n/, $doc) { + # blank lines + next LINE if $line =~ /^\s*$/; + + # comment lines + next LINE if $line =~ /^\s*\#/; + + my @fields = split /\|/, $line; + + # at least fileset, datatime, and type fields are required + if (scalar @fields < 5) { + carp "line $lineno: not enough fields: $line"; + next LINE; + } + + foreach my $field (@fields) { + # fields are not allowed to contain # + if ($field =~ /\#/) { + carp "line $lineno: field $field: contains #: $line"; + next LINE; + } + + # strip leading and trailing whitespace + $field =~ s/^\s+//; + $field =~ s/\s+$//; + } + + my ($product, $last_fileset, $last_datetime, $type, $desc) = @fields; + + # validate format of fileset + unless ($last_fileset =~ $STD_FIELD) { + carp "line $lineno: field $last_fileset:" + . " does not conform to $STD_FIELD: $line"; + next LINE; + } + + # validate format of datetime + unless ($last_datetime =~ $TIME_FIELD) { + carp "line $lineno: field $last_datetime:" + . " does not conform to $TIME_FIELD"; + next LINE; + } + + unless (exists $KNOWN_PRODUCT_TYPES{$type}) { + carp "line $lineno: type $type unknown: $line"; + next LINE; + } + + # fifo + push @data, DataStore::Product->new({ + product => $product, + last_fileset => $last_fileset, + last_datetime => $last_datetime, + type => $type, + desc => $desc, + uri => $self->base_uri . $product . '/index.txt', + }); + } continue { + $lineno++; + } + + return unless @data; + return wantarray ? @data : \@data; +} + +=back + +=head1 SEE ALSO + +L, L + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Record.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Record.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Record.pm (revision 41110) @@ -0,0 +1,118 @@ +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: Record.pm,v 1.7 2006-03-16 22:03:53 jhoblitt Exp $ + +package DataStore::Record; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.01'; + +use base qw( Class::Accessor::Fast ); + +use Carp qw( carp croak ); +use Data::Validate::URI qw( is_uri ); +use Params::Validate qw( validate_with validate SCALAR ); + +use vars qw( @BASE_FIELDS ); + +@BASE_FIELDS = qw( uri ); + +__PACKAGE__->mk_ro_accessors(@BASE_FIELDS); + +=pod + +=head1 NAME + +DataStore::Record - base class of DataStore list records or rows + +=head1 SYNOPSIS + + use base qw( DataStore::Record ); + +=head1 DESCRIPTION + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +=head3 Constructors + +=over 4 + +=item * C + +Basic constructor. + + my $dsp = DataStore::Record->new( + uri => 'http://example.com/', + ); + +Accepts a mandatory hash and returns a L object. + +=over 4 + +=item * uri + +A valid I URI as a string. + +=back + +=cut + +sub new +{ + my $class = shift; + + my %p = validate_with( + params => \@_, + spec => { + uri => { + type => SCALAR, + callbacks => { + 'is valid http uri' => + sub { is_uri($_[0]) and $_[0] =~ /^http:/ }, + }, + default => 'http://example.org/', + }, + }, + allow_extra => 1, + ); + + my $self = bless \%p, ref $class || $class; + + return $self; +} + +=back + +=head3 Object Methods + +=over 4 + +=item * C + +=cut + +=item * C + +This method must be overloaded in sub-classes. + +=cut + +sub request +{ + croak "sub classes of " . __PACKAGE__ + . " must override the ->request() method"; +} + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Response.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Response.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Response.pm (revision 41110) @@ -0,0 +1,173 @@ +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: Response.pm,v 1.4 2006-07-22 01:17:33 smalle Exp $ + +package DataStore::Response; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.01'; + +use base qw( Class::Accessor::Fast ); + +use Params::Validate qw( validate ARRAYREF BOOLEAN SCALAR UNDEF ); + +use vars qw( @BASE_FIELDS ); + +@BASE_FIELDS = qw( is_success code status_line data request ); + +__PACKAGE__->mk_accessors(@BASE_FIELDS); + +=pod + +=head1 NAME + +DataStore::Response - represents a DataStore response + +=head1 SYNOPSIS + + use DataStore::Response; + + my $dsr = DateStore::Response->new( + is_success => undef, + code => 500, + status_line => 'foo', + data => 'bar', + request => DataStore::Product->new( uri => 'http://example.org/' ), + ); + + if ($data) { + my $success = $dsr->is_success; + my $code = $dsr->code; + my $status_line = $dsr->status_line; + my $data = $dsr->data; + my DataStore::Response $response = $dsp->request; + } + +=head1 DESCRIPTION + +This class represent the return state of the C method in +L sub-classes. + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +=head3 Constructors + +=over 4 + +=item * C + +Basic constructor. + + my $dsr = DateStore::Response->new( + is_success => undef, + code => 500, + status_line => 'foo', + data => 'bar', + request => DataStore::Product->new( uri => 'http://example.org/' ), + ); + +Accepts a mandatory hash and returns a L object. + +=over 4 + +=item * uri + +A vvalid I URI as a string. + +=item * code + +An HTTP status code. + +=item * status_line + +An HTTP status line. + +=item * data + +A scalar value, an arrayref of scalar data, or undef. + +=item * request + +An object that I L. + +=back + +=cut + +sub new +{ + my $class = shift; + + my %p = validate(@_, + { + is_success => { + type => BOOLEAN, + callbacks => { + 'is 0, 1, or undef' => + sub { ! defined( $_[0] ) || $_[0] == 0 || $_[0] == 1 }, + }, + }, + code => { + type => SCALAR, + regex => qr/^\d{3}$/, + }, + status_line => { + type => SCALAR, + regex => qr/\S+/, # string with atleast 1 non WS char + + }, + data => { + type => SCALAR | ARRAYREF | UNDEF, + }, + request => { + isa => qw( DataStore::Record ), + }, + } + ); + + my $self = bless \%p, ref $class || $class; + + return $self; +} + +=back + +=head3 Object Methods + +=over 4 + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Root.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Root.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Root.pm (revision 41110) @@ -0,0 +1,190 @@ +# Adapted from Product.pm +# +# Copyright (C) 2006-2008 Joshua Hoblitt +# +# $Id: Root.pm,v 1.5 2008-05-12 22:04:53 jhoblitt Exp $ + +package DataStore::Root; + +use strict; +use warnings; + +use vars qw($VERSION); +$VERSION = '0.02'; + +use base qw( DataStore::Record ); + +use Carp qw( carp ); +use DataStore::Product::Parser; +use DataStore::Record; +use DataStore::Response; +use DataStore::Utils qw( $STD_FIELD ); +use LWP::UserAgent; +use Params::Validate qw( validate SCALAR); + +use vars qw( @BASE_FIELDS ); + +@BASE_FIELDS = qw( last_fileset ); + +__PACKAGE__->mk_ro_accessors(@BASE_FIELDS); + +=pod + +=head1 NAME + +DataStore::Root - container for root DataStore index + +=head1 SYNOPSIS + + use DataStore::Root; + + my $dsp = DataStore::Root->new( + uri => 'http://example.com/productid/', + ); + + my DataStore::Response $response = $dsp->request; + +=head1 DESCRIPTION + +This class I L + +=head1 USAGE + +=head2 Import Parameters + +This module accepts no arguments to it's C method and exports no +I. + +=head2 Methods + +=head3 Constructors + +=over 4 + +=item * C + +Basic constructor. + + my $dsp = DataStore::Root->new( + uri => 'http://example.com/productid/', + ); + +Accepts a mandatory hash and returns a L object. + +=over 4 + +=item * uri + +A valid I URI as a string. I + +=back + +=cut + +sub new +{ + my $class = shift; + + # validates uri, doesn't check other params + my $self = $class->SUPER::new(@_); + + validate(@_, + { + uri => { + type => SCALAR, + callbacks => { + 'uri ends with /index.txt' => + sub { $_[0] =~ m|/index.txt$| }, + } + }, + }, + ); + + return $self; +} + +=back + +=head3 Object Methods + +=over 4 + +=item * C + +Basic accessor. + +=item * C + +Basic accessor. + +=item * C + +Retrieves and processes the FileSet listing pointed to by the L of this +object. + +Accepts no parameters and returns a L object. + +=cut + +sub request +{ + my $self = shift; + + my %p = validate(@_, + { + ua_args => { + optional => 1, + }, + no_proxy => { + type => SCALAR, + optional => 1, + }, + }, + ); + + # make request + my $ua; + if (defined $p{ua_args}) { + $ua = LWP::UserAgent->new(%{$p{ua_args}}); + } else { + $ua = LWP::UserAgent->new; + } + + if (!$p{no_proxy}) { + # load proxy environment variables (if any) + $ua->env_proxy; + } + + my $request = HTTP::Request->new(GET => $self->uri); + my $response = $ua->request($request); + + my $data; + + if ($response->is_success) { + # parse document + my $parser = DataStore::Product::Parser->new(base_uri => $self->uri); + + $data = $parser->parse($response->content); + } + + # return DS::Response object + my $dsr = DataStore::Response->new( + is_success => $response->is_success, + code => $response->code, + status_line => $response->status_line, + data => $data, + request => $self, + ); +} + +=back + +=head1 SEE ALSO + +L + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Utils.pm =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Utils.pm (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/lib/DataStore/Utils.pm (revision 41110) @@ -0,0 +1,104 @@ +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: Utils.pm,v 1.13 2008-08-29 01:39:48 bills Exp $ + +package DataStore::Utils; + +use strict; +use warnings; + +use vars qw( $VERSION ); +$VERSION = '0.02'; + +use base qw( Exporter ); + +use Carp qw( carp ); +use Data::Validate::URI qw( is_uri ); + +use vars qw( + @EXPORT_OK + $STD_FIELD + $TIME_FIELD + $BYTE_FIELD + $MD5_FIELD + %KNOWN_FILE_TYPES + %KNOWN_FILESET_TYPES + %KNOWN_PRODUCT_TYPES +); + +@EXPORT_OK = qw( + @EXPORT_OK + $STD_FIELD + $TIME_FIELD + $BYTE_FIELD + $MD5_FIELD + %KNOWN_FILE_TYPES + %KNOWN_FILESET_TYPES + %KNOWN_PRODUCT_TYPES +); + +$STD_FIELD = qr/^[A-z0-9-+_.: ]+$/; +$TIME_FIELD = qr/^(\d{4})-(\d\d)-(\d\d) T (\d\d):(\d\d):(\d\d) Z$/x; +$BYTE_FIELD = qr/^\d+$/; +$MD5_FIELD = qr/^[0-9a-f]{32}$/; +%KNOWN_FILE_TYPES = map { $_ => 1 } qw( chip psrequest psresults pstamp chipproc warp stack diff ipp-mops table text xml tgz fits IPP-MOPS IPP-PSPS ipp-psps notset ); +%KNOWN_FILESET_TYPES = map { $_ => 1 } qw( OBJECT BIAS DARK SKYFLAT DOMEFLAT OOF SHACKHARTMANN PSREQUEST PSRESULTS IPP-MOPS XRAY FOCUS MOPS_DETECTABILITY_QUERY MOPS_DETECTABILITY_RESPONSE MOPS_TRANSIENT_DETECTIONS LED notset IPP_PSPS IPP-DIST table); +%KNOWN_PRODUCT_TYPES = map { $_ => 1 } qw( image dump psrequest psresults table ipp-dist ipp-misc dqresults IPP-MOPS IPP-PSPS PSRESULTS); + +=pod + +=head1 NAME + +DataStore::Utils - functions and/or regexs common to DataStore::* modules + +=head1 SYNOPSIS + + use DataStore::Utils qw( ... ); + +=head1 DESCRIPTION + +This class parses a DataStore listing of Is into an array of L objects. + +=head1 USAGE + +=head2 Import Parameters + +This module exports no I by default. It will export these symbols upon request: + +=over 4 + +=item * C<$STD_FIELD> + +A C for the standard DataStore list field type. + +=item * C<$TIME_FIELD> + +A C for the standard DataStore time field type. + +=item * C<$BYTE_FIELD> + +A C for the standard DataStore byte field type. + +=item * C<$MD5_FIELD> + +A C for the standard DataStore hex encoded md5 field type. + +=item * C% + +A a hash of the known I types. + +=item * C% + +A a hash of the known I types. + +=back + +=head2 Methods + +None. + +=cut + +1; + +__END__ Index: /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsfilesetls =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsfilesetls (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsfilesetls (revision 41110) @@ -0,0 +1,144 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006-2008 Joshua Hoblitt +# +# $Id: dsfilesetls,v 1.10 2008-05-20 01:09:29 jhoblitt Exp $ + +use strict; +use warnings FATAL => qw( all ); + +use vars qw( $VERSION ); +$VERSION = '0.02'; + +use DataStore; + +use Getopt::Long qw( GetOptions :config auto_help auto_version gnu_getopt ); +use Pod::Usage qw( pod2usage ); + +my ($uri, $timeout, $no_proxy); + +GetOptions( + 'uri|u=s' => \$uri, + 'timeout|t=s' => \$timeout, + 'no-proxy' => \$no_proxy, +) or pod2usage( 2 ); + +pod2usage( -msg => "Unknown option: @ARGV", -exitval => 2 ) if @ARGV; +pod2usage( + -msg => "Required options: --uri", + -exitval => 3, +) unless defined $uri; + +# default http request timeout is 30s +$timeout ||= 30; +$no_proxy = 0 if !defined $no_proxy; + +if (!($uri =~ /\/index\.txt$/)) { + $uri .= '/index.txt' +} + +my $response = DataStore::FileSet->new( uri => $uri )->request( + ua_args => { timeout => $timeout }, + no_proxy => $no_proxy, + ); + +unless (defined $response and $response->is_success) { + warn "request failed: ", $response->status_line; + exit($response->code - 300); +} + +# file retreival succeed + +my $data = $response->data; + +unless ($data) { + warn "no files found"; + exit(0); +} + +print "# uri fileid bytes md5sum type \n"; +foreach my $fs (@$data) { + print + $fs->uri, " ", + $fs->fileid, " ", + $fs->bytes, " ", + $fs->md5sum || 0, " ", + $fs->type; + print " ", join(" ", @{$fs->extra}) if defined $fs->extra; + print "\n"; +} + +__END__ + +=pod + +=head1 NAME + +dsfilesetls - list all the Files under a FileSet from a DataStore server + +=head1 SYNOPSIS + + dsfilesetls --uri + +=head1 DESCRIPTION + +=head1 OPTIONS + +=over 4 + +=item * --uri|-u + +The URI of the file to be retrieved. + +=item * --timeout|-t + +The ammount of time (in seconds) to wait for a response from the DataStore +after making an HTTP request. The default is 30s. + +Optional. + +=item * --no-proxy + +Do not load proxy environment variables. + +Optional. + +=back + +=head1 CREDITS + +Just me, myself, and I. + +=head1 SUPPORT + +Please contact the author directly via e-mail. + +=head1 AUTHOR + +Joshua Hoblitt + +=head1 COPYRIGHT + +Copyright (C) 2006-2008 Joshua Hoblitt. 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 2 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. + +The full text of the license can be found in the L Pod as supplied +with Perl 5.8.1 and later. + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut Index: /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsget =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsget (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsget (revision 41110) @@ -0,0 +1,369 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006-2009 Joshua Hoblitt + +use strict; +use warnings FATAL => qw( all ); + +use vars qw( $VERSION ); +$VERSION = '0.03'; + +use DataStore; +use File::Path qw( mkpath ); +use File::Temp (); +use File::Basename qw( basename dirname ); + +use Getopt::Long qw( GetOptions :config auto_help auto_version gnu_getopt ); +use Pod::Usage qw( pod2usage ); + +my ($uri, + $bytes, + $copies, + $md5, + $nebulous, + $filename, + $volume, + $server, + $compress, + $timeout, + @xattrs, + $no_proxy, +); + +$server = $ENV{'NEB_SERVER'} unless $server; + +GetOptions( + 'uri|u=s' => \$uri, + 'bytes|m=s' => \$bytes, + 'copies=i' => \$copies, + 'nebulous|n' => \$nebulous, + 'volume|v=s' => \$volume, + 'server|s=s' => \$server, + 'md5|m=s' => \$md5, + 'filename|f=s' => \$filename, + 'compress|c' => \$compress, + 'timeout|t=s' => \$timeout, + 'xattr|x=s' => \@xattrs, + 'no-proxy' => \$no_proxy, +) or pod2usage( 2 ); + +pod2usage( -msg => "Unknown option: @ARGV", -exitval => 2 ) if @ARGV; +pod2usage( + -msg => "Required options: --uri --filename", + -exitval => 3, +) unless defined $uri and defined $filename; + +my $date = `date`; +print "starting dsget $date"; + +# XXX EAM : should not need parse_neb_key, but how to handle case +# where we supply --volume and neb://volume/path ? +# 1) parse anyway and check for conflict +# 2) drop --volume option +# JH: the Nebulous server contains the policy to handle this conflict. +# At present --volume will overide the volume in neb://volume/... + +# --volume implies --nebulous +if ($volume) { + $nebulous ||=1; +} + +if (defined $copies) { + if (not defined $nebulous) { + warn "--copies is meanless without --nebulous or --volume"; + undef $copies; + } + elsif ($copies < 1) { + die "--copies must be >= 1"; + } +} + +if ($compress) { + $uri = "$uri?compress"; +} + +# default http request timeout is 30s +$timeout ||= 30; +$no_proxy = 0 if !defined $no_proxy; + +my %p = ( + uri => $uri, + type => 'chip', +); + +$p{bytes} = $bytes if defined $bytes; +$p{md5sum} = $md5 if defined $md5; +$p{compressed} = 1 if defined $compress; + +my $tmp; + +if (!$nebulous) { + + # create path and possibly fix up permissions + my $dirname = dirname($filename); + if (!-d $dirname) { + mkpath([$dirname], 1, 0775); + } + + # can we truly write to filename? +{ + # open file for read/write but not create + my $fh; + if (open($fh, '+<', $filename)) { + # do nothing and fall through + } elsif (open($fh, '>>', $filename)) { + # this is the "stomp on it behavior" this probably shouldn't be the + # default and it may make sense to check the md5sum/bytes count of the + # files that's already in place to see if we really need to re-fetch it + unlink $filename or die "can't unlink $filename: $!"; + } else { + die "can't write to $filename"; + } +} + + # for non-neb files, use the download directory for the tmp file + $tmp = File::Temp->new( + DIR => $dirname, + TEMPLATE => '.' . basename($filename) . '.XXXXXXXX', + SUFFIX => '.tmp', + UNLINK => 1, + ); +} else { + # for neb files, use /tmp for the tmp file + $tmp = File::Temp->new( + DIR => '/tmp', + TEMPLATE => basename($filename) . '.XXXXXXXX', + SUFFIX => '.tmp', + UNLINK => 1, + ); +} + +my $tmpfilename = $tmp->filename; +print "downloading file to $tmpfilename\n"; +$date = `date`; +print "downloading starting $date"; + +# request the file from the remote data store server (save in tmpfilename) +my $response = DataStore::File->new(%p)->request( + filename => $tmpfilename, + ua_args => { timeout => $timeout }, + no_proxy => $no_proxy, + ); + + +unless (defined $response and $response->is_success) { + warn "request failed: ", $response->status_line; + exit($response->code - 300); +} + +die "checksum failed" unless $response->data; + +# file retreival succeed + +# this can't cross a file system boundry so we can assume that a move will +# always be a rename operation instead of a copy and delete. + +$date = `date`; +print "start copying file into nebulous $date"; + +my $neb; +if ($nebulous) { + require Nebulous::Client; + import Nebulous::Client; + require Nebulous::Util; + import Nebulous::Util qw( :standard ); + require File::Copy; + import File::Copy; + + $neb = Nebulous::Client->new( + proxy => $server, + ); + + die "can't connected to Nebulous Server: $server" + unless defined $neb; + + # XXX see comment above about not blindly stomping the file + # - if the key doesn't already exist then create it + # - if it does, delete it so that we end up on the right storage volume + if ($neb->stat($filename)) { + $neb->delete($filename) + or die "Nebulous can't delete key $filename"; + } + + my $fh = $neb->open_create( $filename, $volume ) + or die "Nebulous can't create key $filename"; + + # user.copies is always set to at least 2 + my $user_copies = 2; + if (defined $copies) { + $user_copies = $copies if $copies > 2; + } + $neb->setxattr($filename, "user.copies", 2, "create") + or die "Nebulous can't set xattr on key $filename"; + + if (scalar @xattrs) { + write_xattrs($neb, $filename, @xattrs) + or die "Nebulous set xattrs on key $filename"; + } + + open(my $src_fh, $tmpfilename) or die "can't open file $tmpfilename: $!"; + + File::Copy::copy( $src_fh, $fh ) or die "file copy failed"; + + close($src_fh) or die "can't close file $tmpfilename: $!"; + $fh->flush or die "can't flush nebulous filehandle: $!"; + $fh->sync or die "can't sync nebulous filehandle: $!"; + close($fh) or die "can't close nebulous filehandle: $!"; + + # make any required IMMEDIATE copies + if (defined $copies and $copies > 1) { + foreach (1 .. ($copies - 1)) { + $neb->replicate($filename) + or die "failed to replicate $filename failed: $!"; + } + } +} else { + $tmp->flush or die "can't flush filehandle: $!"; + $tmp->sync or die "can't sync filehandle: $!"; + # set read and write permissions based on umask (ignore other bits) + my $umask = umask; + chmod 0666 ^ $umask, $tmpfilename or die "failed to chmod $tmpfilename"; + rename $tmpfilename, $filename + or die "renaming $tmpfilename to $filename failed: $!"; +} + +DESTROY { + unlink $tmpfilename if -e $tmpfilename; + if ($nebulous and $neb->stat($filename)) { + $neb->delete($filename) + or die "Nebulous can't delete key $filename"; + } +} + +$date = `date`; +print "finished dsget $date"; + +__END__ + +=pod + +=head1 NAME + +dsget - download a file from a DataStore server + +=head1 SYNOPSIS + + dsget --uri --filename [--bytes ] [--md5 ] + [--compress] [--nebulous] [--xattr user.:] + [--volume ] [--copies ] + +=head1 DESCRIPTION + +=head1 OPTIONS + +=over 4 + +=item * --uri|-u + +The URI of the file to be retrieved. + +=item * --filename|-f + +The name to use when writing the file to disk. + +=item * --bytes|-s + +The size of the file in bytes. + +Optional, the size check is skipped if no value is specified. + +=item * --md5|-m + +The md5 checksum of the file in hex. + +Optional, the md5check is skipped if no value is specified. + +=item * --nebulous|-n + +Flag to enable C support. When set C<--filename> is used as the +Nebulous key. + +Optional. + +=item * --xattr|-x + +Flag to set a Nebulous xattr on C<--filename>. Can be specified more than +once. + +Optional. + +=item * --compress|-c + +When set C will request a compressed version of the file. + +Optional. + +=item * --volume|-v + +The volume name to request the first Nebulous instance be stored on. + +Optional, implies C<--nebulous> + +=item * --timeout|-t + +The ammount of time (in seconds) to wait for a response from the DataStore +after making an HTTP request. The default is 30s. + +Optional. + +=item * --no-proxy + +Do not load proxy environment variables. + +Optional. + +=item * --copies + +If C<--nebulous> is in use, the number of Nebulous replications to make. + +Optional. + +=back + +=head1 CREDITS + +Just me, myself, and I. + +=head1 SUPPORT + +Please contact the author directly via e-mail. + +=head1 AUTHOR + +Joshua Hoblitt + +=head1 COPYRIGHT + +Copyright (C) 2006-2009 Joshua Hoblitt. 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 2 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. + +The full text of the license can be found in the L Pod as supplied +with Perl 5.8.1 and later. + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut Index: /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsgetfileset =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsgetfileset (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsgetfileset (revision 41110) @@ -0,0 +1,214 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006-2009 Institute for Astromony University of Hawaii +# +# dsgetfileset + +use strict; +use warnings FATAL => qw( all ); + +use vars qw( $VERSION ); +$VERSION = '0.02'; + +use DataStore; + +use Getopt::Long qw( GetOptions :config auto_help auto_version gnu_getopt ); +use Pod::Usage qw( pod2usage ); +use File::Basename qw( basename ); + +my ($uri, $outdir, $timeout, $skip_checks, $unpack, $first_file, $no_proxy, $verbose); + +GetOptions( + 'uri|u=s' => \$uri, + 'outdir|o=s' => \$outdir, + 'timeout|t=s' => \$timeout, + 'skip-checks' => \$skip_checks, + 'unpack' => \$unpack, + 'first-file=s' => \$first_file, + 'no-proxy' => \$no_proxy, + 'verbose|v' => \$verbose, +) or pod2usage( 2 ); + +pod2usage( -msg => "Unknown option: @ARGV", -exitval => 2 ) if @ARGV; +pod2usage( + -msg => "Required options: --uri --outdir", + -exitval => 3, +) unless defined $uri and defined $outdir; + +# default http request timeout is 30s +$timeout ||= 30; +$no_proxy = 0 if !defined $no_proxy; + +if (!($uri =~ /\/index\.txt$/)) { + $uri .= '/index.txt' +} + +my $response = DataStore::FileSet->new( uri => $uri )->request( + ua_args => { timeout => $timeout }, + no_proxy => $no_proxy, + ); + +unless (defined $response and $response->is_success) { + warn "request failed: ", $response->status_line; + exit($response->code - 300); +} + +# file retreival succeed + +my $data = $response->data; + +unless ($data) { + warn "no files found"; + exit(0); +} + +print "# uri fileid bytes md5sum type \n"; +foreach my $fs (@$data) { + if ($verbose) { + print + $fs->uri, " ", + $fs->fileid, " ", + $fs->bytes, " ", + $fs->md5sum || 0, " ", + $fs->type; + print " ", join(" ", @{$fs->extra}) if defined $fs->extra; + print "\n"; + } + + if ($first_file) { + next if $fs->fileid ne $first_file; + $first_file = undef; + } + my $uri = $fs->uri; + my $base = basename($uri); + my $outfile = "$outdir/$base"; + my $md5 = $fs->md5sum; + my $bytes = $fs->bytes; + + my $command = "dsget --uri $uri --filename $outfile --timeout $timeout"; + $command .= " --md5 $md5 --bytes $bytes" if !$skip_checks; + print "$command\n" if $verbose; + my $rc = system $command; + if ($rc) { + my $status = $rc >> 8; + print STDERR "dsget failed: rc: $rc status: $status\n"; + exit $status; + } + + if ($unpack) { + my $file_type = `file $outfile`; + if ($file_type =~ /FITS/) { + my $packed_file = "${outfile}.fz"; + rename $outfile, $packed_file + or die "failed to rename $outfile $packed_file"; + + # unpack the fits file and delete the input + # This works whether or not the file is compressed + $command = "funpack -D $packed_file"; + print "$command\n" if $verbose; + $rc = system $command; + if ($rc) { + my $status = $rc >> 8; + print STDERR "failed to funpack $outfile: rc: $rc status: $status\n"; + exit $status; + } + } elsif (($file_type =~ /gzip/) and ($outfile =~ /tgz/) ){ + $command = "tar -x --directory $outdir -f $outfile"; + $rc = system $command; + if ($rc) { + my $status = $rc >> 8; + print STDERR "failed to extract $outfile: rc: $rc status: $status\n"; + exit $status; + } + } + } +} + +__END__ + +=pod + +=head1 NAME + +dsgetfilset - download all the Files under a FileSet from a DataStore server + +=head1 SYNOPSIS + + dsgetfileset --uri --outdir + +=head1 DESCRIPTION + +Download the contents of the Data Store Fileset at the supplied uri to a local directory. + +=head1 OPTIONS + +=over 4 + +=item * --uri|-u + +The URI of the file to be retrieved. + +=item * --outdir|-o + +The output destination directory. + +=item * --timeout|-t + +The amount of time (in seconds) to wait for a response from the DataStore +after making an HTTP request. The default is 30s. + +Optional. + +=item * --no-proxy + +Do not load proxy environment variables. + +=item * --unpack + +Uncompress fits files if compressed or extract files from gzipped tar (tgz) files. + +=item * --first-file + +Skip files in fileset list prior to the given fileid. + +Optional. + +=back + +=head1 CREDITS + +Based on the DataStore modules and scripts by Joshua Hoblitt + +=head1 SUPPORT + +None. + +=head1 AUTHOR + +The IPP Team + +=head1 COPYRIGHT + +Copyright (C) 2006-2009 Institute for Astromony University of Hawaii + +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 2 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. + +The full text of the license can be found in the L Pod as supplied +with Perl 5.8.1 and later. + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut Index: /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsleech =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsleech (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsleech (revision 41110) @@ -0,0 +1,330 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006-2008 Joshua Hoblitt +# +# $Id: dsleech,v 1.12 2008-05-19 21:24:15 jhoblitt Exp $ + +use strict; +use warnings FATAL => qw( all ); + +use vars qw( $VERSION ); +$VERSION = '0.02'; + +use DataStore; +use File::Spec; +use YAML (); + +use Getopt::Long qw( GetOptions :config auto_help auto_version gnu_getopt ); +use Pod::Usage qw( pod2usage ); + +my ($dir, $uri, $last_fileset, $overwrite, $recall, $remember, $verbose, $timeout, $no_proxy); + +GetOptions( + 'dir|d=s' => \$dir, + 'uri|u=s' => \$uri, + 'last_fileset|l=s' => \$last_fileset, + 'overwrite|o' => \$overwrite, + 'recall' => \$recall, + 'remember' => \$remember, + 'verbose|v' => \$verbose, + 'timeout|t=i' => \$timeout, + 'no-proxy' => \$no_proxy, +) or pod2usage( 2 ); + +pod2usage( -msg => "Unknown option: @ARGV", -exitval => 2 ) if @ARGV; +pod2usage( + -msg => "Required options: --uri", + -exitval => 3, +) unless defined $uri; + +# default http request timeout is 30s +$timeout ||= 30; +$no_proxy = 0 if !defined $no_proxy; + +my %p = ( + uri => $uri, +); + +# rc file path +my $rcfilename = File::Spec->catfile($ENV{'HOME'}, '.dsleechrc'); + +# load rc file +my $rc = load_rc($rcfilename) or die "failed to load rcfile"; + +$p{last_fileset} = $last_fileset if defined $last_fileset; +if ($recall) { + # if --last_fileset was specified it's value should override --recall + if (defined $last_fileset) { + warn "--last_fileset overriding --recall" if defined $verbose; + } elsif (defined $rc->{$uri}) { + $p{last_fileset} = $rc->{$uri}; + } else { + warn "--recall couldn't find a previous fileset ID" + if defined $verbose; + } +} + +my $response = DataStore::Product->new(%p)->request( + ua_args => { timeout => $timeout }, + no_proxy => $no_proxy, +); + +unless (defined $response and $response->is_success) { + warn "request failed: ", $response->status_line; + exit($response->code - 300); +} + +# file retreival succeed + +my $filesets = $response->data; +unless ($filesets) { + warn "no filesets found"; + exit(0); +} + +print "@$filesets filesets found\n" if $verbose; + +process_filesets($filesets, $dir, $overwrite, $verbose) or die "failed to process filesets"; + +# if we got this far we're assuming that the downloads completed and we can +# save the last fileset +if ($remember) { + my $lowest_fileset = $filesets->[-1]; + if (defined $lowest_fileset) { + $rc->{$uri} = $lowest_fileset->fileset; + } + + save_rc($rcfilename, $rc) or die "failed to save rcfile"; +} + +sub process_filesets +{ + my ($filsets, $dir, $overwrite, $verbose) = @_; + + my $n = 0; + foreach my $fileset (@$filesets) { + $n++; + print "processing fileset: $fileset->fileset $n/@$filesets\n" if $verbose; + + my $response = $fileset->request( + ua_args => { timeout => $timeout }, + ); + unless (defined $response->is_success) { + warn "request failed: ", $response->status_line; + return; + } + + my $files = $response->data; + # if we get an empty fileset ->request will sucessed but ->data will + # return undef + next unless defined $files; + unless (@$files) { + print "no files in fileset ", $fileset->set, "\n" if $verbose; + next; + } + + if (!process_files($files, $dir, $overwrite, $verbose)) { + warn "failed to process files"; + return; + } + } + + return 1; +} + +sub process_files +{ + my ($files, $dir, $overwrite, $vebose) = @_; + + foreach my $file (@$files) { + # generate the filename to downloda too + my $filename; + if (defined $dir) { + if (!-e $dir) { + print "creating dir $dir\n" if $verbose; + mkdir $dir or die "can't create dir: $!"; + } + if (!-d $dir) { + warn "$dir is not a directory"; + return; + } + + $filename = File::Spec->catfile($dir, $file->fileid); + } else { + $filename = $file->fileid; + } + + # make sure that filename doesn't already exist + if (-e $filename) { + if ($overwrite) { + warn "file $filename already exists, overwriting..."; + } else { + warn "file $filename already exists, skipping..."; + next; + } + } + + # use the short version of the filename (with out the path) + print "fetching ", $file->fileid, "..." if $verbose; + + my $response = $file->request( + filename => $filename, + ua_args => { timeout => $timeout }, + ); + unless (defined $response->is_success) { + warn "request failed: ", $response->status_line; + return; + } + + unless ($response->data) { + warn "there was a problem retreiving ", $file->fileid; + return; + } + + print " ok\n" if $verbose; + } + + return 1; +} + +sub load_rc { + my $rcfilename = shift; + + # initalize $sums with an empty hash so if there isn't a pre-existing + # database we still end up with a hashref instead of an undef scalar + my $rc; + if (-e $rcfilename) { + if (-f $rcfilename) { + $rc = YAML::LoadFile($rcfilename) or die "failed to load rc file"; + } else { + warn "$rcfilename is not a plain file"; + return; + } + } + + # if the rcfile exists but is empty YAML will return undef + $rc ||= {}; + + return $rc; +} + +sub save_rc { + my ($rcfilename, $rc) = @_; + + my $yaml = YAML::DumpFile($rcfilename, $rc) + or die "failed to write rc file"; + + return 1; +} + +__END__ + +=pod + +=head1 NAME + +dsleech - batch retrieve files from a DataStore server product + +=head1 SYNOPSIS + + dsleech --uri [--dir ] [--last_fileset ] + [--overwrite] [--recall] [--remember] [--verbose] + +=head1 DESCRIPTION + +=head1 OPTIONS + +=over 4 + +=item * --uri|-u + +The URI of the DataStore product to retrive files from. + +=item * --dir|-d + +This flag is optional. + +The directory to download retrived files into. The default is to fetch files into the current directory. + +=item * --last_fileset|-l + +The FileSet ID of the last FileSet that you've seen. Only filesets registered after C will be polled for files to retreive. + +This flag is optional. + +=item * --overwrite + +If a file already exists, overwrite it. + +This flag is optional. + +=item * --recall + +Load the last fileset ID seen for C<--uri> from the I, if it exists. + +This flag is optional. + +=item * --remember + +Store the last fileset ID seen for C<--uri> in the I. + +This flag is optional. + +=item * --verbose|-v + +Be more verbose in reporting actions. + +This flag is optional. + +=item * --timeout|-t + +The ammount of time (in seconds) to wait for a response from the DataStore +after making an HTTP request. The default is 30s. + +Optional. + +=item * --no-proxy + +Do not load proxy environment variables. + +Optional. + +=back + +=head1 CREDITS + +Just me, myself, and I. + +=head1 SUPPORT + +Please contact the author directly via e-mail. + +=head1 AUTHOR + +Joshua Hoblitt + +=head1 COPYRIGHT + +Copyright (C) 2006-2008 Joshua Hoblitt. 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 2 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. + +The full text of the license can be found in the L Pod as supplied +with Perl 5.8.1 and later. + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut Index: /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsproductls =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsproductls (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsproductls (revision 41110) @@ -0,0 +1,164 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006-2008 Joshua Hoblitt +# +# $Id: dsproductls,v 1.7 2008-07-29 05:49:53 bills Exp $ + +use strict; +use warnings FATAL => qw( all ); + +use vars qw( $VERSION ); +$VERSION = '0.02'; + +use DataStore; + +use Getopt::Long qw( GetOptions :config auto_help auto_version gnu_getopt ); +use Pod::Usage qw( pod2usage ); + +my ($uri, $last_fileset, $timeout, $extra, $no_proxy); + +GetOptions( + 'uri|u=s' => \$uri, + 'last_fileset|l=s' => \$last_fileset, + 'timeout|t=s' => \$timeout, + 'extra|e' => \$extra, + 'no-proxy' => \$no_proxy, +) or pod2usage( 2 ); + +pod2usage( -msg => "Unknown option: @ARGV", -exitval => 2 ) if @ARGV; +pod2usage( + -msg => "Required options: --uri", + -exitval => 3, +) unless defined $uri; + +# default http request timeout is 30s +$timeout ||= 30; +$no_proxy = 0 if !defined $no_proxy; + +if (!($uri =~ /\/index\.txt$/)) { + $uri .= '/index.txt' +} + +my %p = ( + uri => $uri, +); + +$p{last_fileset} = $last_fileset if defined $last_fileset; + +my $response = DataStore::Product->new(%p)->request( + ua_args => { timeout => $timeout }, + no_proxy => $no_proxy, + ); + +unless (defined $response and $response->is_success) { + warn "request failed: ", $response->status_line; + exit($response->code - 300); +} + +# file retreival succeed + +my $data = $response->data; + +unless ($data) { + warn "no filesets found"; + exit(0); +} + +print "# uri fileset datetime type\n"; +foreach my $fs (@$data) { + print $fs->uri, " ", $fs->fileset, " ", $fs->datetime, " ", $fs->type; + if ($extra) { + my $cols = $fs->extra; + foreach my $col (@$cols) { + print " ", $col; + } + } + print "\n"; +} + +__END__ + +=pod + +=head1 NAME + +dsproductls - list all the FileSets under a product from a DataStore server + +=head1 SYNOPSIS + + dsproductls --uri [--last_fileset ] + +=head1 DESCRIPTION + +=head1 OPTIONS + +=over 4 + +=item * --uri|-u + +The URI of the file to be retrieved. + +=item * --last_fileset|-l + +The FileSet ID of the last FileSet that you've seen. + +This flag is optional. + +=item * --timeout|-t + +The ammount of time (in seconds) to wait for a response from the DataStore +after making an HTTP request. The default is 30s. + +Optional. + +=item * --extra|-e + +Print out any extra columns in the listing. + +Optional. + +=item * --no-proxy + +Do not load proxy environment variables. + +Optional. + +=back + +=head1 CREDITS + +Just me, myself, and I. + +=head1 SUPPORT + +Please contact the author directly via e-mail. + +=head1 AUTHOR + +Joshua Hoblitt + +=head1 COPYRIGHT + +Copyright (C) 2006-2008 Joshua Hoblitt. 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 2 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. + +The full text of the license can be found in the L Pod as supplied +with Perl 5.8.1 and later. + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut Index: /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsrootls =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsrootls (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/scripts/dsrootls (revision 41110) @@ -0,0 +1,146 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006-2008 Joshua Hoblitt +# +# $Id: dsrootls,v 1.4 2008-05-19 21:24:15 jhoblitt Exp $ + +use strict; +use warnings FATAL => qw( all ); + +use vars qw( $VERSION ); +$VERSION = '0.01'; + +use DataStore; + +use Getopt::Long qw( GetOptions :config auto_help auto_version gnu_getopt ); +use Pod::Usage qw( pod2usage ); + +my ($uri, $timeout, $no_proxy); + +GetOptions( + 'uri|u=s' => \$uri, + 'timeout|t=i' => \$timeout, + 'no-proxy' => \$no_proxy, +) or pod2usage( 2 ); + +pod2usage( -msg => "Unknown option: @ARGV", -exitval => 2 ) if @ARGV; +pod2usage( + -msg => "Required options: --uri", + -exitval => 3, +) unless defined $uri; + +# default http request timeout is 30s +$timeout ||= 30; +$no_proxy = 0 if !defined $no_proxy; + +if (!($uri =~ /\/index\.txt$/)) { + $uri .= '/index.txt' +} + +my %p = ( + uri => $uri, +); + +my $response = DataStore::Root->new(%p)->request( + ua_args => { timeout => $timeout }, + no_proxy => $no_proxy, + ); + +unless (defined $response and $response->is_success) { + warn "request failed: ", $response->status_line; + exit($response->code - 300); +} + +# file retreival succeed + +my $data = $response->data; + +unless ($data) { + warn "no products found"; + exit(0); +} + +print "# uri product last time type desc\n"; +foreach my $prod (@$data) { + print $prod->uri, " ", + $prod->product, " ", + $prod->last_fileset, " ", + $prod->last_datetime, " ", + $prod->type, " ", + $prod->desc, "\n"; +} + +__END__ + +=pod + +=head1 NAME + +dsrootls - list all the Product under the "root" of a DataStore server + +=head1 SYNOPSIS + + dsrootls --uri + +=head1 DESCRIPTION + +=head1 OPTIONS + +=over 4 + +=item * --uri|-u + +The URI of the file to be retrieved. + +=item * --timeout|-t + +The ammount of time (in seconds) to wait for a response from the DataStore +after making an HTTP request. The default is 30s. + +Optional. + +=item * --no-proxy + +Do not load proxy environment variables. + +Optional. + +=back + +=head1 CREDITS + +Just me, myself, and I. + +=head1 SUPPORT + +Please contact the author directly via e-mail. + +=head1 AUTHOR + +Joshua Hoblitt + +=head1 COPYRIGHT + +Copyright (C) 2006-2008 Joshua Hoblitt. 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 2 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. + +The full text of the license can be found in the L Pod as supplied +with Perl 5.8.1 and later. + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/00_distribution.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/00_distribution.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/00_distribution.t (revision 41110) @@ -0,0 +1,25 @@ +#!/usr/bin/env perl + +# Copyright (C) 2005 Joshua Hoblitt +# +# $Id: 00_distribution.t,v 1.2 2006-03-16 22:04:38 jhoblitt Exp $ + +use strict; +use warnings FATAL => qw( all ); + +use lib qw( ./lib ./t ); + +use Test::More; + +# example taken from Test::Distribution Pod + +BEGIN { + eval { + require Test::Distribution; + }; + if($@) { + plan skip_all => 'Test::Distribution not installed'; + } else { + import Test::Distribution; # not => qw( podcover ); + } +} Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/01_load.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/01_load.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/01_load.t (revision 41110) @@ -0,0 +1,19 @@ +# -*- perl -*- + +# t/001_load.t - check module loading and create testing directory + +use lib qw( ./lib ./t ); + +use Test::More tests => 11; + +BEGIN { use_ok('DataStore'); } +BEGIN { use_ok('DataStore::File'); } +BEGIN { use_ok('DataStore::File::Parser'); } +BEGIN { use_ok('DataStore::FileSet'); } +BEGIN { use_ok('DataStore::FileSet::Parser'); } +BEGIN { use_ok('DataStore::Product'); } +BEGIN { use_ok('DataStore::Product::Parser'); } +BEGIN { use_ok('DataStore::Root'); } +BEGIN { use_ok('DataStore::Record'); } +BEGIN { use_ok('DataStore::Response'); } +BEGIN { use_ok('DataStore::Utils'); } Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/02_fileset_parse.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/02_fileset_parse.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/02_fileset_parse.t (revision 41110) @@ -0,0 +1,188 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 02_fileset_parse.t,v 1.10 2007-09-25 23:50:34 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::More tests => 43; +use Test::Warn; + +=head1 NAME + +t/02_fileset_parse.t - tests DataStore::FileSet::Parser + +=head1 SYNOPSIS + + prove t/02_fileset_parse.t + +=cut + +use DataStore::FileSet::Parser; +#use Test::Warn; + +can_ok('DataStore::FileSet::Parser', qw( + new + parse +)); + +# ->new() + +{ + my $parser = DataStore::FileSet::Parser->new; + + isa_ok($parser, 'DataStore::FileSet::Parser'); +} + +# ->parse() + +eval { + my $parser = DataStore::FileSet::Parser->new; + + $parser->parse(undef); +}; +like($@, qr/is not one of the allowed types/, + '->parse() fails when passed undef'); + +eval { + my $parser = DataStore::FileSet::Parser->new; + + $parser->parse(''); +}; +like($@, qr/ did not pass regex check/, + '->parse() fails when passed a zero length string'); + +warning_like { + my $parser = DataStore::FileSet::Parser->new; + + is($parser->parse('asdf|asdf'), undef, + '->parse() returns undef on failure'); +} qr/not enough fields/, + '->parse() fails when there are too few fields'; + +warning_like { + my $parser = DataStore::FileSet::Parser->new; + + is($parser->parse('|2006-01-01T00:03:04Z|OBJECT'), undef, + '->parse() returns undef on failure'); +} qr/does not conform /, + '->parse() fails when the fileset field is not in the proper format'; + +warning_like { + my $parser = DataStore::FileSet::Parser->new; + + is($parser->parse('foobar|2006-01-0100:03:04Z|OBJECT'), undef, + '->parse() returns undef on failure'); +} qr/does not conform /, + '->parse() fails when the datetime field is not in the proper format'; + +warning_like { + my $parser = DataStore::FileSet::Parser->new; + + is($parser->parse('foobar|2006-01-01T00:03:04Z| '), undef, + '->parse() returns undef on failure'); +} qr/does not conform /, + '->parse() fails when the type field is not in the proper format'; + +warning_like { + my $parser = DataStore::FileSet::Parser->new; + + is($parser->parse('foo#bonkbar|2006-01-01T00:03:04Z|baz'), undef, + '->parse() returns undef on failure'); +} qr/contains #/, + '->parse() fails when a field contains #'; + +warning_like { + my $parser = DataStore::FileSet::Parser->new; + + is($parser->parse('foobar|2006-01-01T00:03:04Z|baz # foo'), undef, + '->parse() returns undef on failure'); +} qr/contains #/, + '->parse() comments are not allowed after the last field'; + +{ + # multi-row example +my $example1 =<new( + base_uri => 'http://foo.com/index.txt' + ); + my @results = $parser->parse($example1); + + is(scalar @results, 4, "correct number of item returned in list context"); +} + +{ + # multi-row example +my $example1 =<new( + base_uri => 'http://foo.com/index.txt' + ); + my $results = $parser->parse($example1); + + is(scalar @$results, 4, + "correct number of item returned in scalar context"); + + isa_ok(@$results[0], 'DataStore::FileSet'); + is(@$results[0]->fileset, 'otis0123456', 'correct fileset'); + is(@$results[0]->datetime, '2006-01-01T00:03:04Z', 'correct datetime'); + is(@$results[0]->type, 'OBJECT', 'correct type'); + is(@$results[0]->uri, 'http://foo.com/otis0123456/index.txt', 'correct uri'); + + isa_ok(@$results[1], 'DataStore::FileSet'); + is(@$results[1]->fileset, 'otis0123456', 'correct fileset'); + is(@$results[1]->datetime, '2006-01-01T00:03:04Z', 'correct datetime'); + is(@$results[1]->type, 'OBJECT', 'correct type'); + is(@$results[1]->uri, 'http://foo.com/otis0123456/index.txt', 'correct uri'); + + isa_ok(@$results[2], 'DataStore::FileSet'); + is(@$results[2]->fileset, 'otis0123456', 'correct fileset'); + is(@$results[2]->datetime, '2006-01-01T00:03:04Z', 'correct datetime'); + is(@$results[2]->type, 'OBJECT', 'correct type'); + is(@$results[2]->uri, 'http://foo.com/otis0123456/index.txt', 'correct uri'); + + isa_ok(@$results[3], 'DataStore::FileSet'); + is(@$results[3]->fileset, 'otis0123456', 'correct fileset'); + is(@$results[3]->datetime, '2006-01-01T00:03:04Z', 'correct datetime'); + is(@$results[3]->type, 'OBJECT', 'correct type'); + is(@$results[3]->uri, 'http://foo.com/otis0123456/index.txt', 'correct uri'); +} + +{ + # example with blank lines & comments +my $example1 =<new->parse($example1); + + is(scalar @$results, 1, "correct number of item returned"); + + isa_ok(@$results[0], 'DataStore::FileSet'); + is(@$results[0]->fileset, 'otis0123456', 'correct fileset'); + is(@$results[0]->datetime, '2006-01-01T00:03:04Z', 'correct datetime'); + is(@$results[0]->type, 'OBJECT', 'correct type'); +} Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/03_file_parse.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/03_file_parse.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/03_file_parse.t (revision 41110) @@ -0,0 +1,200 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 03_file_parse.t,v 1.5 2007-09-26 00:44:43 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::More tests => 50; +use Test::Warn; + +=head1 NAME + +t/03_file_parse.t - tests DataStore::File::Parser + +=head1 SYNOPSIS + + prove t/03_file_parse.t + +=cut + +use DataStore::File::Parser; +#use Test::Warn; + +can_ok('DataStore::File::Parser', qw( + new + parse +)); + +# ->new() + +{ + my $parser = DataStore::File::Parser->new; + + isa_ok($parser, 'DataStore::File::Parser'); +} + +# ->parse() + +eval { + my $parser = DataStore::File::Parser->new; + + $parser->parse(undef); +}; +like($@, qr/is not one of the allowed types/, + '->parse() fails when passed undef'); + +eval { + my $parser = DataStore::File::Parser->new; + + $parser->parse(''); +}; +like($@, qr/ did not pass regex check/, + '->parse() fails when passed a zero length string'); + +warning_like { + my $parser = DataStore::File::Parser->new; + + is($parser->parse('asdf|asdf'), undef, + '->parse() returns undef on failure'); +} qr/not enough fields/, + '->parse() fails when there are too few fields'; + +warning_like { + my $parser = DataStore::File::Parser->new; + + is($parser->parse( + 'foo+++bar|83002312|fe6a2b6564c0d4cfb3bbf1db813824ba|chip|'), undef, + '->parse() returns undef on failure'); +} qr/does not conform/, + '->parse() fails when the fileID field is not in the proper format'; + +warning_like { + my $parser = DataStore::File::Parser->new; + + is($parser->parse( + 'otis0123456.01|a83002312|fe6a2b6564c0d4cfb3bbf1db813824ba|chip|'), undef, + '->parse() returns undef on failure'); +} qr/does not conform/, + '->parse() fails when the bytes field is not in the proper format'; + +warning_like { + my $parser = DataStore::File::Parser->new; + + is($parser->parse( + 'otis0123456.01|83002312|zfe6a2b6564c0d4cfb3bbf1db813824ba|chip|'), undef, + '->parse() returns undef on failure'); +} qr/does not conform/, + '->parse() fails when the md5sum field is not in the proper format'; + +warning_like { + my $parser = DataStore::File::Parser->new; + + is($parser->parse( + 'otis0123456.01|83002312|fe6a2b6564c0d4cfb3bbf1db813824ba|c+hip|'), undef, + '->parse() returns undef on failure'); +} qr/does not conform/, + '->parse() fails when the fileID field is not in the proper format'; + +warning_like { + my $parser = DataStore::File::Parser->new; + + is($parser->parse( + 'otis012#3456.01|83002312|fe6a2b6564c0d4cfb3bbf1db813824ba|chip|'), undef, + '->parse() returns undef on failure'); +} qr/contains #/, + '->parse() fails when a field contains #'; + +warning_like { + my $parser = DataStore::File::Parser->new; + + is($parser->parse( + 'otis0123456.01|83002312|fe6a2b6564c0d4cfb3bbf1db813824ba|chip| # foo'), undef, + '->parse() returns undef on failure'); +} qr/contains #/, + '->parse() comments are not allowed after the last field'; + +{ + # multi-row example +my $example1 =<new->parse($example1); + is(scalar @results, 4, "correct number of item returned in list context"); +} + +{ + # multi-row example +my $example1 =<new->parse($example1); + + is(scalar @$results, 4, + "correct number of item returned in scalar context"); + + isa_ok(@$results[0], 'DataStore::File'); + is(@$results[0]->uri, 'http://example.org/otis0123456.01', 'correct uri'); + is(@$results[0]->fileid, 'otis0123456.01', 'correct fileid'); + is(@$results[0]->bytes, '83002312', 'correct datetime'); + is(@$results[0]->md5sum, 'fe6a2b6564c0d4cfb3bbf1db813824ba', 'correct md5'); + is(@$results[0]->type, 'chip', 'correct type'); + + isa_ok(@$results[1], 'DataStore::File'); + is(@$results[1]->uri, 'http://example.org/otis0123456.02', 'correct uri'); + is(@$results[1]->fileid, 'otis0123456.02', 'correct fileid'); + is(@$results[1]->bytes, '83002312', 'correct datetime'); + is(@$results[1]->md5sum, 'a2b4a7d7b94dc6076c5f3f67239a48c6', 'correct md5'); + is(@$results[1]->type, 'chip', 'correct type'); + + isa_ok(@$results[2], 'DataStore::File'); + is(@$results[2]->uri, 'http://example.org/otis0123456.03', 'correct uri'); + is(@$results[2]->fileid, 'otis0123456.03', 'correct fileid'); + is(@$results[2]->bytes, '83002312', 'correct datetime'); + is(@$results[2]->md5sum, 'a39b1510484c7833e27454b181f13981', 'correct md5'); + is(@$results[2]->type, 'chip', 'correct type'); + + isa_ok(@$results[3], 'DataStore::File'); + is(@$results[3]->uri, 'http://example.org/otis0123456.04', 'correct uri'); + is(@$results[3]->fileid, 'otis0123456.04', 'correct fileid'); + is(@$results[3]->bytes, '83002312', 'correct datetime'); + is(@$results[3]->md5sum, '7bb35e1e30f3f833c0416aea75f90304', 'correct md5'); + is(@$results[3]->type, 'chip', 'correct type'); +} + +{ + # example with blank lines & comments +my $example1 =<new->parse($example1); + + is(scalar @$results, 1, "correct number of item returned"); + + isa_ok(@$results[0], 'DataStore::File'); + is(@$results[0]->fileid, 'otis0123456.01', 'correct fileid'); + is(@$results[0]->bytes, '83002312', 'correct datetime'); + is(@$results[0]->md5sum, 'fe6a2b6564c0d4cfb3bbf1db813824ba', 'correct md5'); + is(@$results[0]->type, 'chip', 'correct type'); +} Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/04_record.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/04_record.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/04_record.t (revision 41110) @@ -0,0 +1,81 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 04_record.t,v 1.1 2006-02-28 03:56:46 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::More tests => 7; +use DataStore::Record; + +=head1 NAME + +t/04_record.t - tests DataStore::Record + +=head1 SYNOPSIS + + prove t/04_record.t + +=cut + +can_ok('DataStore::Record', qw( + new + uri + request +)); + +# ->new() + +{ + my $rec = DataStore::Record->new; + + isa_ok($rec, 'DataStore::Record'); +} + +{ + # w/o trailing slash + my $rec = DataStore::Record->new( + uri => 'http://example.org/foo' + ); + + isa_ok($rec, 'DataStore::Record'); +} + +{ + # w/ trailing slash + my $rec = DataStore::Record->new( + uri => 'http://example.org/foo/' + ); + + isa_ok($rec, 'DataStore::Record'); +} + +# ->uri() + +{ + # default value + my $rec = DataStore::Record->new; + is($rec->uri, 'http://example.org/', '->uri() returned default uri'); +} + +{ + # default value + my $rec = DataStore::Record->new( + uri => 'http://example.org/foo/' + ); + is($rec->uri, 'http://example.org/foo/', '->uri() returned correct uri'); +} + +# ->request() + +eval { + my $rec = DataStore::Record->new; + + $rec->request; +}; +like($@, qr/must override the ->request\(\) method/, + '->request() dies when not overridden'); Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/05_product.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/05_product.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/05_product.t (revision 41110) @@ -0,0 +1,181 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 05_product.t,v 1.6 2007-09-25 23:37:44 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::More tests => 23; + +=head1 NAME + +t/05_product.t - tests DataStore::Product + +=head1 SYNOPSIS + + prove t/05_product.t + +=cut + +use DataStore::Product; + +can_ok('DataStore::Product', qw( + new + request +)); + +# ->new() + +{ + my $dsp = DataStore::Product->new( uri => 'http://example.org/index.txt' ); + + isa_ok($dsp, 'DataStore::Product'); +} + +{ + my $dsp = DataStore::Product->new( + uri => 'http://example.org/index.txt', + last_fileset => '12buckelyourshoe', + ); + + isa_ok($dsp, 'DataStore::Product'); +} + +eval { + my $dsp = DataStore::Product->new( uri => 'http://example.org/index.txt', foo => 1 ); +}; +like($@, qr/not listed in the validation options/, + '->new() fails whe passed extra params'); + +eval { + my $dsp = DataStore::Product->new( + uri => 'http://example.org/index.txt', + last_fileset => '12buckelyourshoe', + foo => 1, + ); +}; +like($@, qr/not listed in the validation options/, + '->new() fails whe passed extra params'); + +eval { + my $dsp = DataStore::Product->new( uri => 'http://example.org' ); +}; +like($@, qr/uri ends with \/index.txt/, + '->new() fails when uri param does not end with /index.txt'); + +eval { + my $dsp = DataStore::Product->new( uri => 'http://example.org/index.html' ); +}; +like($@, qr/uri ends with \/index.txt/, + '->new() fails when uri param does not end with /index.txt'); + +eval { + my $dsp = DataStore::Product->new( uri => '://example.org/index.txt' ); +}; +like($@, qr/is valid http uri/, + '->new() fails when uri param is not http protocol'); + +eval { + my $dsp = DataStore::Product->new( + uri => 'http://example.org/index.txt', + last_fileset => '++12buckelyourshoe', + ); +}; +like($@, qr/is valid fileset ID/, + '->new() fails when last_fileset param is not a valid fileset ID'); + +eval { + my $dsp = DataStore::Product->new; +}; +like($@, qr/Mandatory parameter 'uri'/, + '->new() fails when not passed a uri param'); + +eval { + my $dsp = DataStore::Product->new( + last_fileset => '12buckelyourshoe', + ); +}; +like($@, qr/Mandatory parameter 'uri'/, + '->new() fails when not passed a uri param'); + +# ->request() + +use Net::HTTPServer; + +sub bar +{ + my $req = shift; # Net::HTTPServer::Request object + my $res = $req->Response(); # Net::HTTPServer::Response object + + my $string = <Print($string); + + return $res; +} + +$|++; + +$SIG{CHLD} = 'IGNORE'; +my $pid = open(my $child, "-|"); + +unless ($pid) { + my $server = new Net::HTTPServer( port => 'scan', log => '/dev/null' ); + + # send port number to parent + print $server->Start(), "\n"; + + $server->RegisterURL('/index.txt', \&bar); + $server->Process(); # Run forever + + exit -1; +} + +my $port = <$child>; +chomp $port; + +{ + my $dsp = DataStore::Product->new( uri => "http://localhost:$port/index.txt" ); + + isa_ok($dsp->request, 'DataStore::Response'); +} + +{ + my $dsp = DataStore::Product->new( uri => "http://localhost:$port/index.txt" ); + + my $dsr = $dsp->request; + + ok($dsr->is_success, "response->is_success() is correct"); + is($dsr->code, 200, "response->code() is correct"); + is($dsr->status_line, "200 OK", "response->status_line() is correct"); + is(ref $dsr->data, 'ARRAY', "response->data is arrayref is correct"); + isa_ok($dsr->request, 'DataStore::Record'); + + my $data = $dsr->data; + is(scalar @$data, 4, "data has the correct number of rows"); + isa_ok(@$data[0], 'DataStore::FileSet', "data has correct type of rows"); + isa_ok(@$data[1], 'DataStore::FileSet', "data has correct type of rows"); + isa_ok(@$data[2], 'DataStore::FileSet', "data has correct type of rows"); + isa_ok(@$data[3], 'DataStore::FileSet', "data has correct type of rows"); +} + +# cleanup HTTP server +kill 9, $pid; + +eval { + my $dsp = DataStore::Product->new( uri => 'http://example.org/index.txt' ); + + $dsp->request( foo => 1 ); +}; +like($@, qr/not listed in the validation options/, + '->request() fails whe passed extra params'); Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/06_fileset.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/06_fileset.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/06_fileset.t (revision 41110) @@ -0,0 +1,172 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 06_fileset.t,v 1.9 2007-09-25 23:50:34 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::More tests => 19; + +=head1 NAME + +t/06_fileset.t - tests DataStore::FileSet + +=head1 SYNOPSIS + + prove t/06_fileset.t + +=cut + +use DataStore::FileSet; + +can_ok('DataStore::FileSet', qw( + new + request +)); + +# ->new() + +{ + my $dsf = DataStore::FileSet->new( + uri => 'http://example.org/index.txt', + fileset => '12buckelyourshoe', + datetime => '2042-01-01T00:00:00Z', + type => 'OBJECT', + ); + + isa_ok($dsf, 'DataStore::FileSet'); +} + +eval { + my $dsf = DataStore::FileSet->new( + uri => 'http://example.org/index.txt', + fileset => '12buckelyourshoe', + datetime => '2042-01-01T00:00:00Z', + type => 'OBJECT', + foo => 1, + ); +}; +like($@, qr/not listed in the validation options/, + '->new() fails whe passed extra params'); + +eval { + my $dsf = DataStore::FileSet->new( uri => 'http://example.org' ); +}; +like($@, qr/uri ends with \/index.txt/, + '->new() fails when uri param does not end with /'); + +eval { + my $dsf = DataStore::FileSet->new( uri => 'http://example.org/index.html' ); +}; +like($@, qr/uri ends with \/index.txt/, + '->new() fails when uri param does not end with /'); + +eval { + my $dsf = DataStore::FileSet->new( uri => '://example.org/index.txt' ); +}; +like($@, qr/is valid http uri/, + '->new() fails when uri param is not http protocol'); + +eval { + my $dsp = DataStore::FileSet->new; +}; +like($@, qr/Mandatory parameter/, + '->new() fails when not passed all manadator params'); + +# ->request() + +use Net::HTTPServer; + +sub bar +{ + my $req = shift; # Net::HTTPServer::Request object + my $res = $req->Response(); # Net::HTTPServer::Response object + + my $string = <Print($string); + + return $res; +} + +$|++; + +$SIG{CHLD} = 'IGNORE'; +my $pid = open(my $child, "-|"); + +unless ($pid) { + my $server = new Net::HTTPServer( port => 'scan', log => '/dev/null' ); + + # send port number to parent + print $server->Start(), "\n"; + + $server->RegisterURL('/index.txt', \&bar); + $server->Process(); # Run forever + + exit -1; +} + +my $port = <$child>; +chomp $port; + +{ + my $dsp = DataStore::FileSet->new( + uri => "http://localhost:$port/index.txt", + fileset => '12buckelyourshoe', + datetime => '2042-01-01T00:00:00Z', + type => 'OBJECT', + ); + + isa_ok($dsp->request, 'DataStore::Response'); +} + +{ + my $dsp = DataStore::FileSet->new( + uri => "http://localhost:$port/index.txt", + fileset => '12buckelyourshoe', + datetime => '2042-01-01T00:00:00Z', + type => 'OBJECT', + ); + + my $dsr = $dsp->request; + + ok($dsr->is_success, "response->is_success() is correct"); + is($dsr->code, 200, "response->code() is correct"); + is($dsr->status_line, "200 OK", "response->status_line() is correct"); + is(ref $dsr->data, 'ARRAY', "response->data is arrayref is correct"); + isa_ok($dsr->request, 'DataStore::Record'); + + my $data = $dsr->data; + is(scalar @$data, 4, "data has the correct number of rows"); + isa_ok(@$data[0], 'DataStore::File', "data has correct type of rows"); + isa_ok(@$data[1], 'DataStore::File', "data has correct type of rows"); + isa_ok(@$data[2], 'DataStore::File', "data has correct type of rows"); + isa_ok(@$data[3], 'DataStore::File', "data has correct type of rows"); +} + +# cleanup HTTP server +kill 9, $pid; + +eval { + my $dsf = DataStore::FileSet->new( + uri => 'http://example.org/index.txt', + fileset => '12buckelyourshoe', + datetime => '2042-01-01T00:00:00Z', + type => 'OBJECT', + ); + + $dsf->request( foo => 1 ); +}; +like($@, qr/not listed in the validation options/, + '->request() fails whe passed extra params'); + Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/07_file.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/07_file.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/07_file.t (revision 41110) @@ -0,0 +1,180 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 07_file.t,v 1.5 2006-03-17 23:54:35 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::More tests => 14; + +=head1 NAME + +t/07_file.t - tests DataStore::File + +=head1 SYNOPSIS + + prove t/07_file.t + +=cut + +use DataStore::File; +use File::Temp (); + +can_ok('DataStore::File', qw( + new + request +)); + +# ->new() + +{ + my $dsf = DataStore::File->new( + uri => 'http://example.org/foo', + fileid => '12buckelyourshoe', + bytes => 12345, + md5sum => 'fe6a2b6564c0d4cfb3bbf1db813824ba', + type => 'chip', + ); + + isa_ok($dsf, 'DataStore::File'); +} + +eval { + my $dsf = DataStore::File->new( + uri => 'http://example.org/foo', + fileid => '12buckelyourshoe', + bytes => 12345, + md5sum => 'fe6a2b6564c0d4cfb3bbf1db813824ba', + type => 'chip', + foo => 1, + ); +}; +like($@, qr/not listed in the validation options/, + '->new() fails whe passed extra params'); + +eval { + my $dsf = DataStore::File->new( uri => 'http://example.org/' ); +}; +like($@, qr/is valid uri filename/, + '->new() fails when uri param does not end with /'); + +eval { + my $dsf = DataStore::File->new( uri => '://example.org' ); +}; +like($@, qr/is valid http uri/, + '->new() fails when uri param is not http protocol'); + +eval { + my $dsf = DataStore::File->new; +}; +like($@, qr/Mandatory parameter/, + '->new() fails when not passed all manadator params'); + +# ->request() + +use Net::HTTPServer; + +sub bar +{ + my $req = shift; # Net::HTTPServer::Request object + my $res = $req->Response(); # Net::HTTPServer::Response object + + my $string = "foobarbaz"; + + $res->Print($string); + + return $res; +} + +$|++; + +$SIG{CHLD} = 'IGNORE'; +my $pid = open(my $child, "-|"); + +unless ($pid) { + my $server = new Net::HTTPServer( port => 'scan', log => '/dev/null' ); + + # send port number to parent + print $server->Start(), "\n"; + + $server->RegisterURL('/somefile', \&bar); + $server->Process(); # Run forever + + exit -1; +} + +my $port = <$child>; +chomp $port; + +{ + my $dsf = DataStore::File->new( + uri => "http://localhost:$port/somefile", + fileid => '12buckelyourshoe', + bytes => 10, + md5sum => 'a0a6e1a375117c58d77221f10c5ce12e', + type => 'chip', + ); + + my $fh = File::Temp->new( UNLINK => 1 ); + $fh->autoflush(1); + isa_ok($dsf->request( filename => $fh->filename ), 'DataStore::Response'); +} + +{ + my $dsf = DataStore::File->new( + uri => "http://localhost:$port/somefile", + fileid => '12buckelyourshoe', + bytes => 10, + md5sum => 'a0a6e1a375117c58d77221f10c5ce12e', + type => 'chip', + ); + + my $fh = File::Temp->new( UNLINK => 1 ); + $fh->autoflush(1); + my $dsr = $dsf->request( filename => $fh->filename ); + + ok($dsr->is_success, "response->is_success() is correct"); + is($dsr->code, 200, "response->code() is correct"); + is($dsr->status_line, "200 OK", "response->status_line() is correct"); + is($dsr->data, $fh->filename, "response->data is arrayref is correct"); + isa_ok($dsr->request, 'DataStore::Record'); +} + +# stop HTTP server +kill 9, $pid; + +eval { + my $dsf = DataStore::File->new( + uri => 'http://example.org/foo', + fileid => '12buckelyourshoe', + bytes => 12345, + md5sum => 'fe6a2b6564c0d4cfb3bbf1db813824ba', + type => 'chip', + ); + + $dsf->request; +}; +like($@, qr/Mandatory parameter/, + '->request() fails when passed no params'); + +eval { + my $dsf = DataStore::File->new( + uri => 'http://example.org/foo', + fileid => '12buckelyourshoe', + bytes => 12345, + md5sum => 'fe6a2b6564c0d4cfb3bbf1db813824ba', + type => 'chip', + ); + + my $fh = File::Temp->new( UNLINK => 1 ); + $dsf->request( + filename => $fh->filename, + foo => 1, + ); +}; +like($@, qr/not listed in the validation options/, + '->request() fails whe passed extra params'); Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/08_response.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/08_response.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/08_response.t (revision 41110) @@ -0,0 +1,96 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 08_response.t,v 1.3 2007-09-25 23:37:44 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::More tests => 8; + +=head1 NAME + +t/08_response.t - tests DataStore::Response + +=head1 SYNOPSIS + + prove t/08_response.t + +=cut + +use CGI; +use DataStore::Product; +use DataStore::Response; + +can_ok('DataStore::Response', qw( + new + is_success + code + status_line + data + request +)); + +# ->new() + +{ + my $dsr = DataStore::Response->new( + is_success => undef, + code => 500, + status_line => 'foo', + data => 'bar', + request => DataStore::Product->new( uri => 'http://example.org/index.txt' ), + ); + + isa_ok($dsr, 'DataStore::Response'); +} + +eval { + my $dsr = DataStore::Response->new( + is_success => undef, + code => 500, + status_line => 'foo', + data => 'bar', + request => DataStore::Product->new( uri => 'http://example.org/index.txt' ), + foo => 1, + ); +}; +like($@, qr/not listed in the validation options/, + '->new() fails whe passed extra params'); + +eval { + my $dsr = DataStore::Response->new( is_success => 2 ); +}; +like($@, qr/is 0, 1, or undef/, + '->new() fails when is_success is not valid'); + +eval { + my $dsr = DataStore::Response->new( code => 5000 ); +}; +like($@, qr/did not pass regex check/, + '->new() fails when code is not valid'); + +eval { + my $dsr = DataStore::Response->new( status_line => '' ); +}; +like($@, qr/did not pass regex check/, + '->new() fails when status_line is not valid'); + +eval { + my $dsr = DataStore::Response->new( + request => CGI->new, + ); +}; +like($@, qr/was not a 'DataStore::Record' /, + '->new() fails when response is not valid'); + +eval { + my $dsr = DataStore::Response->new; +}; +like($@, qr/Mandatory parameters/, + '->new() fails when not passed all manadator params'); + +# accessor tests unneeded as they are all generated by Class::Accessor::Fast Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/09_datastore.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/09_datastore.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/09_datastore.t (revision 41110) @@ -0,0 +1,33 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 09_datastore.t,v 1.2 2006-03-16 01:23:10 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::More tests => 7; + +=head1 NAME + +t/09_datastore.t - tests DataStore + +=head1 SYNOPSIS + + prove t/09_datastore.t + +=cut + +use DataStore; + +ok(%DataStore::, "DataStore is loaded"); +ok(%DataStore::File::Parser::, "DataStore::File::Parser is loaded"); +ok(%DataStore::File::, "DataStore::File is loaded"); +ok(%DataStore::FileSet::Parser::, "DataStore::FileSet::Parser is loaded"); +ok(%DataStore::FileSet::, "DataStore::Set is loaded"); +ok(%DataStore::Product::, "DataStore::Product is loaded"); +ok(%DataStore::Response::, "DataStore::Response is loaded"); + Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/10_dsget.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/10_dsget.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/10_dsget.t (revision 41110) @@ -0,0 +1,53 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 10_dsget.t,v 1.2 2006-03-17 21:58:23 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::Cmd; +use Test::More tests => 7; + +=head1 NAME + +t/10_dsget.t - tests dsget + +=head1 SYNOPSIS + + prove t/10_dsget.t + +=cut + +# last ditch effort to make sure dsget is executable +chmod 0755, 'scripts/dsget'; + +my $test = Test::Cmd->new(prog => 'scripts/dsget', workdir => ''); +isa_ok($test, 'Test::Cmd'); + +{ + $test->run(args => ''); + missing_args(3, "Required options: --uri --filename"); +} + +{ + $test->run(args => '--uri http://example.org/foo'); + missing_args(3, "Required options: --uri --filename"); +} + +{ + $test->run(args => '--filename /foo/bar/baz'); + missing_args(3, "Required options: --uri --filename"); +} + +sub missing_args +{ + my ($exit, $errstr) = @_; + + is($? >> 8, $exit, "error code is: $exit"); + like($test->stderr, qr/$errstr/, "error string is: $errstr"); +} + Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/11_dsproductls.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/11_dsproductls.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/11_dsproductls.t (revision 41110) @@ -0,0 +1,48 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 11_dsproductls.t,v 1.1 2006-03-18 04:02:35 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::Cmd; +use Test::More tests => 5; + +=head1 NAME + +t/11_dsproductls.t - tests dsproductls + +=head1 SYNOPSIS + + prove t/11_dsproductls.t + +=cut + +# last ditch effort to make sure dsproductls is executable +chmod 0755, 'scripts/dsproductls'; + +my $test = Test::Cmd->new(prog => 'scripts/dsproductls', workdir => ''); +isa_ok($test, 'Test::Cmd'); + +{ + $test->run(args => ''); + missing_args(3, "Required options: --uri"); +} + +{ + $test->run(args => '--last_fileset foobar'); + missing_args(3, "Required options: --uri"); +} + +sub missing_args +{ + my ($exit, $errstr) = @_; + + is($? >> 8, $exit, "error code is: $exit"); + like($test->stderr, qr/$errstr/, "error string is: $errstr"); +} + Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/12_dsfilesetls.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/12_dsfilesetls.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/12_dsfilesetls.t (revision 41110) @@ -0,0 +1,45 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 12_dsfilesetls.t,v 1.1 2006-03-20 22:03:53 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::Cmd; +use Test::More tests => 3; + +=head1 NAME + +t/12_dsfilesetls.t - tests dsfilesetls + +=head1 SYNOPSIS + + prove t/12_dsfilesetls.t + +=cut + +my $prog = 'scripts/dsfilesetls'; + +# last ditch effort to make sure dsproductls is executable +chmod 0755, $prog; + +my $test = Test::Cmd->new( prog => $prog, workdir => '' ); +isa_ok($test, 'Test::Cmd'); + +{ + $test->run( args => '' ); + missing_args(3, "Required options: --uri"); +} + +sub missing_args +{ + my ($exit, $errstr) = @_; + + is($? >> 8, $exit, "error code is: $exit"); + like($test->stderr, qr/$errstr/, "error string is: $errstr"); +} + Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/13_dsrootls.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/13_dsrootls.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/13_dsrootls.t (revision 41110) @@ -0,0 +1,45 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006 Joshua Hoblitt +# +# $Id: 13_dsrootls.t,v 1.1 2007-09-25 22:10:45 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::Cmd; +use Test::More tests => 3; + +=head1 NAME + +t/12_dsfilesetls.t - tests dsfilesetls + +=head1 SYNOPSIS + + prove t/12_dsfilesetls.t + +=cut + +my $prog = 'scripts/dsrootls'; + +# last ditch effort to make sure dsproductls is executable +chmod 0755, $prog; + +my $test = Test::Cmd->new( prog => $prog, workdir => '' ); +isa_ok($test, 'Test::Cmd'); + +{ + $test->run( args => '' ); + missing_args(3, "Required options: --uri"); +} + +sub missing_args +{ + my ($exit, $errstr) = @_; + + is($? >> 8, $exit, "error code is: $exit"); + like($test->stderr, qr/$errstr/, "error string is: $errstr"); +} + Index: /branches/ccl_branches/ipponly-20191108/DataStore/t/14_root.t =================================================================== --- /branches/ccl_branches/ipponly-20191108/DataStore/t/14_root.t (revision 41110) +++ /branches/ccl_branches/ipponly-20191108/DataStore/t/14_root.t (revision 41110) @@ -0,0 +1,166 @@ +#!/usr/bin/env perl + +# Copyright (C) 2006-2007 Joshua Hoblitt +# +# $Id: 14_root.t,v 1.1 2007-09-26 00:51:22 jhoblitt Exp $ + +use strict; +use warnings; + +use lib qw( ./lib ./t ); + +use Test::More tests => 21; + +=head1 NAME + +t/14_root.t - tests DataStore::Root + +=head1 SYNOPSIS + + prove t/14_root.t + +=cut + +use DataStore::Root; + +can_ok('DataStore::Root', qw( + new + request +)); + +# ->new() + +{ + my $dsp = DataStore::Root->new( uri => 'http://example.org/index.txt' ); + + isa_ok($dsp, 'DataStore::Root'); +} + +eval { + my $dsp = DataStore::Root->new( + uri => 'http://example.org/index.txt', + foo => 1 + ); +}; +like($@, qr/not listed in the validation options/, + '->new() fails whe passed extra params'); + +eval { + my $dsp = DataStore::Root->new( + uri => 'http://example.org/index.txt', + last_fileset => '12buckelyourshoe', + foo => 1, + ); +}; +like($@, qr/not listed in the validation options/, + '->new() fails whe passed extra params'); + +eval { + my $dsp = DataStore::Root->new( uri => 'http://example.org' ); +}; +like($@, qr/uri ends with \/index.txt/, + '->new() fails when uri param does not end with /index.txt'); + +eval { + my $dsp = DataStore::Root->new( uri => 'http://example.org/index.html' ); +}; +like($@, qr/uri ends with \/index.txt/, + '->new() fails when uri param does not end with /index.txt'); + +eval { + my $dsp = DataStore::Root->new( uri => '://example.org/index.txt' ); +}; +like($@, qr/is valid http uri/, + '->new() fails when uri param is not http protocol'); + +eval { + my $dsp = DataStore::Root->new; +}; +like($@, qr/Mandatory parameter 'uri'/, + '->new() fails when not passed a uri param'); + +eval { + my $dsp = DataStore::Root->new( + last_fileset => '12buckelyourshoe', + ); +}; +like($@, qr/not listed in the validation options/, + '->new() fails when not passed a uri param'); + +# ->request() + +use Net::HTTPServer; + +sub bar +{ + my $req = shift; # Net::HTTPServer::Request object + my $res = $req->Response(); # Net::HTTPServer::Response object + + my $string = <Print($string); + + return $res; +} + +$|++; + +$SIG{CHLD} = 'IGNORE'; +my $pid = open(my $child, "-|"); + +unless ($pid) { + my $server = new Net::HTTPServer( port => 'scan', log => '/dev/null' ); + + # send port number to parent + print $server->Start(), "\n"; + + $server->RegisterURL('/index.txt', \&bar); + $server->Process(); # Run forever + + exit -1; +} + +my $port = <$child>; +chomp $port; + +{ + my $dsp = DataStore::Root->new( uri => "http://localhost:$port/index.txt" ); + + isa_ok($dsp->request, 'DataStore::Response'); +} + +{ + my $dsp = DataStore::Root->new( uri => "http://localhost:$port/index.txt" ); + + my $dsr = $dsp->request; + + ok($dsr->is_success, "response->is_success() is correct"); + is($dsr->code, 200, "response->code() is correct"); + is($dsr->status_line, "200 OK", "response->status_line() is correct"); + is(ref $dsr->data, 'ARRAY', "response->data is arrayref is correct"); + isa_ok($dsr->request, 'DataStore::Record'); + + my $data = $dsr->data; + is(scalar @$data, 4, "data has the correct number of rows"); + isa_ok(@$data[0], 'DataStore::Product', "data has correct type of rows"); + isa_ok(@$data[1], 'DataStore::Product', "data has correct type of rows"); + isa_ok(@$data[2], 'DataStore::Product', "data has correct type of rows"); + isa_ok(@$data[3], 'DataStore::Product', "data has correct type of rows"); +} + +# cleanup HTTP server +kill 9, $pid; + +eval { + my $dsp = DataStore::Root->new( uri => 'http://example.org/index.txt' ); + + $dsp->request( foo => 1 ); +}; +like($@, qr/not listed in the validation options/, + '->request() fails whe passed extra params');