Download this file
#!/usr/bin/perl -w
# This is fotowire.pl version 0.1, a free implementation of the FotoWire
# protocol and command-line client.
# Copyright (c) 2003 Matthieu Weber
#
# 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.
# Or, point your browser to http://www.gnu.org/copyleft/gpl.html
#
# Author: Matthieu Weber
# E-mail: mweber@mit.jyu.fi
$DEBUG = 0;
$min_print_res = 150; # in dots/in
$config_dir = "$ENV{HOME}/.fotowire";
$config_file = "$config_dir/fotowirerc";
$session = "$config_dir/session";
$log_file = "$config_dir/log";
$debug_file = "$config_dir/debug";
$labs_xml = "$config_dir/labs.xml";
$labinfos_xml = "$config_dir/labinfos.xml";
$file_max_age = 86400; # in seconds
use HTTP::Request::Common;
use LWP::UserAgent;
use URI;
use XML::Twig;
use Unicode::MapUTF8 qw(from_utf8);
use Image::Info qw(image_info dim);
my @std_hdr = (
'Connection' => 'Keep-Alive',
'Accept-Language' => 'en',
);
sub get_elt_text {
my ($node, $gi) = @_;
return from_utf8(-string => $node->first_child($gi)->text,
-charset => 'ISO-8859-1');
}
sub cmp_file_date {
# returns -1 if f1 less recent than f2
# 0 if f1 as recent as f2
# 1 if f1 more recent than f2
my ($f1, $f2) = @_;
return (stat($f1))[9] <=> (stat($f2))[9];
}
sub file_too_old {
my $f = shift(@_);
return (stat($f))[9] + $file_max_age < time();
}
sub log_open {
open(LOG,">>$log_file");
$log_opened = 1;
}
sub log_close {
$log_opened = 0;
close(LOG);
}
sub log {
my $s = shift(@_);
if ($log_opened) {
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
printf LOG "%04d/%02d/%02d %02d:%02d:%02d %s\n",
$year+1900, $mon+1, $mday, $hour, $min, $sec, $s;
}
else {
print STDERR "Log file is not opened!\n";
}
}
sub debug {
my $s = shift(@_);
open(DEBUG, ">>$debug_file");
print DEBUG localtime(time)."\n";
print DEBUG "$s\n\n";
close(DEBUG);
}
sub _die {
my $s = shift(@_);
print STDERR "$s. Exit.\n";
&log("DIED $s");
&log_close();
exit(1);
}
sub code_url_param {
my $s = shift(@_);
$s =~ s/ /+/g;
$s =~ s/[^A-Za-z0-9-]/sprintf("%%%x")/eg;
return $s;
}
sub url {
my ($scheme, $authority, $path, $query) = @_;
my $u = URI->new;
$u->scheme($scheme);
$u->authority($authority);
$u->path($path) if defined $path;
$u->query_form(@{$query}) if defined $query;
return $u->as_string();
}
sub check_status {
my ($fun_name, $t) = @_;
if ($t->root->first_child('Status')) {
my $status = $t->root->first_child('Status')->first_child('Code')->text;
if ($status != 0) {
_die "$fun_name status = $status".": ".
&get_elt_text($t->root->first_child('Status'), 'Description');
}
}
}
sub get_list_labs {
&log("get_list_labs");
my $req = GET &url("http",$master, "/fworder/listlabs3.asp",
[
"CN" => $customer_info{CountryCode},
]
),
@std_hdr;
my $res = $ua->request($req);
_die "get_list_labs failed" unless ($res->is_success);
&save_xml_doc($labs_xml, $res->content);
&parse_list_labs($res->content);
}
sub parse_list_labs {
my $doc = shift(@_);
my $t = XML::Twig->new();
$t->parse($doc);
my @lablist = $t->root->children('Lab');
foreach $lab (@lablist) {
my $id = &get_elt_text($lab,'ID');
foreach $e ('Name', 'Addr', 'City', 'State', 'Zip', 'Ctry',
'Tel', 'Fax', 'TargetCtry', 'InfoURL', 'Opt') {
$labs{$id}->{$e} = &get_elt_text($lab,$e);
}
}
}
sub print_list_labs {
print "\n***** Labs *****\n";
foreach $l (sort {
my $l1 = $labs{$a}->{Ctry} cmp $labs{$b}->{Ctry};
if ($l1 == 0) {
$labs{$a}->{Name} cmp $labs{$b}->{Name};
}
else {
$l1;
}
} keys(%labs)) {
printf " %6d: [$labs{$l}->{Ctry}] $labs{$l}->{Name}, $labs{$l}->{City}\n", $l;
}
print "\n";
}
sub get_version {
&log("get_version");
my $res = $ua->request(
GET &url("http", $master, "/fworder/fwver.asp",
[
"LID" => $lab_ID,
"OEM" => $lab_ID,
"UPID"=> $lab_ID,
"VER" => '3.0.0.123',
"RD" => '98cc3',
]),
@std_hdr,
);
}
sub get_lab_url {
&log("get_lab_url");
my $req = GET &url("http", $master, "/fworder/getlaburl.asp",
[
"LID" => $lab_ID,
"RD" => '98d5a',
]
),
@std_hdr;
my $res = $ua->request($req);
_die "get_lab_url failed" unless ($res->is_success);
my $t = XML::Twig->new();
$t->parse($res->content);
&check_status("get_lab_url", $t);
my @lablist = $t->root->children('Lab');
foreach $lab (@lablist) {
my $id = &get_elt_text($lab,'ID');
foreach $e ('HTTPServer', 'HTTPPath') {
$labs{$id}->{$e} = &get_elt_text($lab, $e);
}
}
}
sub get_lab_info {
&log("get_lab_info");
my @content = (
"LID" => $lab_ID,
"DID" => '',
"RD" => '98d96',
);
push @content, ( PROMO => $promo_code) if $promo_code;
my $res = $ua->request(
GET &url("http", $labs{$lab_ID}->{HTTPServer},
$labs{$lab_ID}->{HTTPPath}."getlabinfo3.asp",
\@content,
),
@std_hdr
);
_die "get_lab_info failed" unless ($res->is_success);
&save_xml_doc($labinfos_xml, $res->content);
&parse_lab_info($res->content);
}
sub parse_lab_info {
my $xml = shift(@_);
my $t = XML::Twig->new();
$t->parse($xml);
my @lablist = $t->root->children('Lab');
foreach $lab (@lablist) {
my $lid = &get_elt_text($lab, 'ID');
foreach $e ('Name', 'Addr', 'City', 'State', 'Zip', 'Ctry',
'Tel', 'Fax', 'TargetCtry', 'InfoURL', 'HTTPServer',
'HTTPPath', 'Currency', 'TaxInfoMsg', 'InfoMsg',
'Opt', 'InfoMsgWeb', 'Validity', 'MinOrder') {
next unless $lab->first_child($e);
$labs{$lid}->{$e} = &get_elt_text($lab, $e);
}
my @pml = $lab->first_child('PayMethodList')->children('PayMethod');
foreach $pm (@pml) {
my $id = &get_elt_text($pm, 'ID');
foreach $e ('Description', 'Explanation', 'CardType') {
$labs{$lid}->{'PayMethod'}->{$id}->{$e} = &get_elt_text($pm, $e);
}
}
my @pl = $lab->first_child('ProductList')->children('Product');
foreach $p (@pl) {
my $id = &get_elt_text($p,'ID');
foreach $e ('Description', 'UnitPriceN', 'MinImageXRes', 'MinImageYRes',
'SizeX', 'SizeY') {
$labs{$lid}->{'Product'}->{$id}->{$e} = &get_elt_text($p, $e);
}
}
my @sml = $lab->first_child('ShipMethodList')->children('ShipMethod');
foreach $sm (@sml) {
my $id = &get_elt_text($sm,'ID');
foreach $e ('Description', 'PriceN') {
$labs{$lid}->{'ShipMethod'}->{$id}->{$e} = &get_elt_text($sm, $e);
}
}
}
}
sub print_lab_basics {
my $lid = shift(@_);
print "Information for $labs{$lid}->{'Name'} ($lid):\n";
print " $labs{$lid}->{'Name'}\n";
print " $labs{$lid}->{'Addr'}\n";
print " $labs{$lid}->{'Zip'} $labs{$lid}->{'City'}\n";
print " $labs{$lid}->{'Ctry'}\n";
print " Tel: $labs{$lid}->{'Tel'}\n";
print " Fax: $labs{$lid}->{'Fax'}\n";
print "\n";
print "$labs{$lid}->{'MinOrder'}\n" if $labs{$lid}->{'MinOrder'};
print "$labs{$lid}->{'InfoMsg'}\n" if $labs{$lid}->{'TaxInfoMsg'};
print "$labs{$lid}->{'TaxInfoMsg'}\n" if $labs{$lid}->{'TaxInfoMsg'};
print "$labs{$lid}->{'InfoMsgWeb'}\n" if $labs{$lid}->{'TaxInfoMsg'};
print "\n";
}
sub print_lab_paymethod {
my $lid = shift(@_);
my %paymethod = %{$labs{$lid}->{'PayMethod'}};
print "Pay methods for $labs{$lid}->{'Name'} ($lid):\n";
foreach $id (keys(%paymethod)) {
printf " %4d: %s (%s)", $id, $paymethod{$id}->{Description}, $paymethod{$id}->{Explanation};
printf " [%s]", $paymethod{$id}->{CardType} if $paymethod{$id}->{CardType};
print "\n";
}
print "\n";
}
sub print_lab_products {
my $lid = shift(@_);
my %product = %{$labs{$lid}->{'Product'}};
print "Products for $labs{$lid}->{Name} ($lid):\n";
foreach $id (sort {$product{$a}->{Description} cmp $product{$b}->{Description}} keys(%product)) {
printf " %4d: %-40s (> %4d x %4d) %5.2f %s \n", $id, $product{$id}->{Description},
$product{$id}->{'MinImageXRes'}, $product{$id}->{'MinImageYRes'},
$product{$id}->{'UnitPriceN'}, $labs{$lid}->{'Currency'};
}
print "\n";
}
sub print_lab_shipmethods {
my $lid = shift(@_);
my %shipmethod = %{$labs{$lid}->{'ShipMethod'}};
print "Ship methods for $labs{$lid}->{Name} ($lid):\n";
foreach $id (keys(%shipmethod)) {
printf " %4d: %-40s %s %s\n", $id, $shipmethod{$id}->{Description},
$shipmethod{$id}->{PriceN}, $labs{$lid}->{'Currency'};
}
print "\n";
}
sub post_customer_info {
&log("post_customer_info");
my @content = (
LID => $lab_ID,
CID => 0,
PW => '',
);
foreach $key (keys(%customer_info)) {
push @content, ($key => $customer_info{$key});
}
my $req= POST &url("http", $labs{$lab_ID}->{HTTPServer},
$labs{$lab_ID}->{HTTPPath}."customerset3.asp"),
\@content,
@std_hdr;
my $res = $ua->request($req);
_die "post_customer_info failed" unless ($res->is_success);
my $t = XML::Twig->new();
$t->parse($res->content);
&check_status("post_customer_info", $t);
open(SESSION,">$session") || _die "Cannot open session file $session";
foreach $e ('ID', 'PW') {
$customer_info{$e} = &get_elt_text($t->root->first_child('Customer'), $e);
print SESSION "\$customer_info{$e} = $customer_info{$e};\n";
}
print SESSION "1;\n";
close(SESSION);
}
sub get_img_dim {
my ($file) = @_;
my $info = image_info($file);
_die "Cannot parse image info: $info->{error}" if $info->{error};
return dim($info);
}
sub eval_resolution {
# This function is awful, and can probably be optimized
# For now, we'll do with the comments
my ($x, $y, $paper_x, $paper_y, $crop) = @_;
# By default, we suppose the image and the paper are horizontal (landscape)
my $img_horiz = 1;
my $pap_horiz = 1;
# Ratio of the sides of the image
my $img_rap = $x / $y;
if ($img_rap < 1) {
# We want a number > 1
$img_rap = 1 / $img_rap;
# However, if the number was < 1, we know the image/paper was vertical
# (portrait)
$img_horiz = 0;
}
# And we want only 3 significative digits.
$img_rap = int (100 * $img_rap) / 100;
# Same as above, but with the paper
my $pap_rap = $paper_x / $paper_y;
if ($pap_rap < 1) {
$pap_rap = 1 / $pap_rap;
$pap_horiz = 0;
}
$pap_rap = int (100 * $pap_rap) / 100;
# The ratio of the image length over paper length gives the horizontal
# resolution. If one element was vertical and the other horizontal, we need
# to swap the length and height of one of the elements.
my $x_res = int(25.4 * $x / ($pap_horiz == $img_horiz ? $paper_x : $paper_y));
# Same with vertical resolution
my $y_res = int(25.4 * $y / ($pap_horiz == $img_horiz ? $paper_y : $paper_x));
if ($img_horiz) {
# If the image is horizontal, then the white bands are on the sides,
# and the crop area is on top/bottom
$crop_side = "top/bottom";
$white_bands = "left/right";
}
else {
# Inverse of the above if the image is vertical
$crop_side = "left/right";
$white_bands = "top/bottom";
}
if ($img_rap < $pap_rap) {
# If the image ratio is lower than the paper ratio (i.e. 4:3 image in a
# 3:2 paper), and if the image is cropped and if the image is horizontal,
# then the image resolution is x_res; otherwise it is y_res
return $crop ? ($img_horiz ? $x_res : $y_res, "cropped ".$crop_side) : ($img_horiz ? $y_res : $x_res, "white bands ".$white_bands);
}
elsif ($img_rap == $pap_rap) {
# This is if the image fits perfectly the paper
return ($x_res, "");
}
else {
# This is unlikely to happen (unless we put a panorama image in a 4:3
# or 3:2 paper)
return $crop ? ($img_horiz ? $y_res : $x_res, "cropped".$crop_side) : ($img_horiz ? $x_res : $y_res, "white bands".$white_bands);
}
}
sub read_order_from_file {
&log("read_order_from_file");
my $order_file = shift(@_);
my $silent = shift(@_);
open(ORDER,"$order_file") || _die "Cannot open order $order_file";
my $header = 1;
my $line_count = 1;
my $item_count = 0;
print "\n***** Your order *****\n" unless $silent;
while() {
s/\r?\n//;
if ($header) {
if ($_ eq "") {
$header = 0;
print "Items:\n" unless $silent;
}
else {
my ($k, $v) = split(/\s+/);
if ($k =~ /ShipMethod|PayMethod/ && $v =~ /\d+/) {
$order{$k} = $v;
_die "Illegal value for $k in $order_file, line $line_count" unless exists $labs{$lab_ID}->{$k}->{$v};
print "$k: $labs{$lab_ID}->{$k}->{$v}->{'Description'}\n" unless $silent;
}
else {
_die "Syntax error in $order_file, line $line_count";
}
}
}
else {
my ($pid, $qty, $file) = (/^(\S+)\s+(\S+)\s+(.*)$/);
_die "Product ID '$pid' is not a number in $order_file, line $line_count" unless $pid =~ /^\d+$/;
_die "Quantity '$qty' is not a number in $order_file, line $line_count" unless $qty =~ /^\d+$/;
my $opts = "";
($file, $opts, $opts_arg) = ($1, $2, $3) if ($file =~ /(.*) (crop|nocrop) ?(.*)$/);
my ($x, $y) = &get_img_dim($file);
_die "File $file does not exist in $order_file, line $line_count" unless -e $file;
_die "Product $pid does not exist in $order_file, line $line_count" unless exists $labs{$lab_ID}->{'Product'}->{$pid};
_die "Option $opts does not exist in $order_file, line $line_count" unless $opts =~ /^crop$|^nocrop$/ || $opts eq "";
my ($min_x, $min_y) = ($labs{$lab_ID}->{'Product'}->{$pid}->{'MinImageXRes'},
$labs{$lab_ID}->{'Product'}->{$pid}->{'MinImageYRes'});
($min_x, $min_y) = ($min_y, $min_x) if (($x < $y) && ($min_x > $min_y)) || (($x > $y) && ($min_x < $min_y));
_die sprintf "The resolution of file %s (%d x %d) is below the limit for the chosen format (%d x %d)",
$file, $x, $y, $min_x, $min_y if $x < $min_x || $y < $min_y;
$order{items}->[$item_count]->{'ProductID'} = $pid;
$order{items}->[$item_count]->{'Quantity'} = $qty;
$order{items}->[$item_count]->{'File'} = $file;
$order{items}->[$item_count]->{'X'} = $x;
$order{items}->[$item_count]->{'Y'} = $x;
my ($res, $aspect) = eval_resolution($x, $y, $labs{$lab_ID}->{'Product'}->{$pid}->{'SizeY'},
$labs{$lab_ID}->{'Product'}->{$pid}->{'SizeX'},
$opts eq "crop" ? 1 : 0);
printf " %2d x %-35s [%-35s]\n Res: %d dpi %s%s\n\n",
$qty, $file, $labs{$lab_ID}->{'Product'}->{$pid}->{'Description'},
$res, $res < $min_print_res ? "LOW RES ":"", $aspect unless $silent;
$order{items}->[$item_count]->{'CT'} = 1;
$order{items}->[$item_count]->{'CB'} = 1;
$order{items}->[$item_count]->{'CL'} = 1;
$order{items}->[$item_count]->{'CR'} = 1;
$order{items}->[$item_count]->{'QW'} = 1;
$order{items}->[$item_count]->{'FC'} = 0;
$item_count ++;
}
$line_count ++;
}
close(ORDER);
_die "Order is empty!" unless exists $order{items};
}
sub post_order_evaluate {
&log("post_order_evaluate");
my @content = (
LID => $lab_ID,
CID => $customer_info{ID},
CPW => $customer_info{PW},
SID => $order{ShipMethod},
AID => $order{PayMethod},
OEM => $lab_ID,
);
foreach $item (@{$order{items}}) {
push @content, (
PID => $item->{ProductID},
Q => $item->{Quantity}
);
}
my $req = POST &url("http", $labs{$lab_ID}->{HTTPServer},
$labs{$lab_ID}->{HTTPPath}."orderevaluate3.asp"),
\@content,
@std_hdr;
&debug($req->as_string());
my $res = $ua->request($req);
_die "post_order_evaluate failed" unless ($res->is_success);
&debug($res->as_string);
my $t = XML::Twig->new();
$t->parse($res->content);
&check_status("post_order_evaluate", $t);
print "\n***** Order evaluation *****\n";
print &get_elt_text($t->root, 'Information')."\n\n";
my @items = $t->root->first_child('ItemList')->children('Item');
foreach $i (@items) {
print "\n",next if $i->is_empty;
print &get_elt_text($i,'Description').": ".
&get_elt_text($i,'UnitPrice')." x ".
&get_elt_text($i,'Quantity')." = ".
&get_elt_text($i,'Price')." $labs{$lab_ID}->{'Currency'}\n";
}
print "\n";
my @totals = $t->root->first_child('TotalList')->children('Item');
foreach $i (@totals) {
print "\n",next if $i->is_empty;
print &get_elt_text($i,'Description').": ".
&get_elt_text($i,'Price')." $labs{$lab_ID}->{'Currency'}\n";
}
}
sub post_order_start {
&log("post_order_start");
my $proto = 'http';
my $pay_by_card = $labs{$lab_ID}->{PayMethod}->{$order{PayMethod}}->{CardType} eq ''?0:1;
$proto = 'https' if $pay_by_card;
my @content = (
LID => $lab_ID,
CID => $customer_info{ID},
CPW => $customer_info{PW},
SID => $order{ShipMethod},
AID => $order{PayMethod},
OEM => $lab_ID,
);
if ($pay_by_card) {
push @content, (
CN => $card_info{Number},
CEM => $card_info{ExpirationMonth},
CEY => $card_info{ExpirationYear},
CO => $card_info{OwnerName},
);
}
else {
push @content, (
CN => '',
CEM => '',
CEY => '',
CO => ''
);
}
my $req= POST &url($proto, $labs{$lab_ID}->{HTTPServer},
$labs{$lab_ID}->{HTTPPath}."orderstart3.asp"),
\@content, @std_hdr;
my $res = $ua->request($req);
_die "post_order_start failed" unless ($res->is_success);
&debug($res->content);
my $t = XML::Twig->new();
$t->parse($res->content);
&check_status("post_order_start", $t);
foreach $e ('SessionID', 'NextFileName', 'HTTPUplServer', 'HTTPUplPath',
'FTPServer', 'FTPPath') {
$order{$e} = &get_elt_text($t->root,$e);
}
}
sub post_file_upload {
&log("post_file_upload");
my $item_number = shift(@_);
my $res = $ua->request(
POST &url("http", $order{HTTPUplServer},
$order{HTTPUplPath}."newimage3.asp"),
Content_Type => 'form-data',
Content => [
SRV => $labs{$lab_ID}->{HTTPServer},
PATH => $labs{$lab_ID}->{HTTPPath},
OID => $order{SessionID},
PID => $order{items}->[$item_number]->{'ProductID'},
Q => $order{items}->[$item_number]->{'Quantity'},
FS => (stat($order{items}->[$item_number]->{'File'}))[7],
FC => $order{items}->[$item_number]->{'FC'},
IX => $order{items}->[$item_number]->{'X'},
IY => $order{items}->[$item_number]->{'Y'},
QW => $order{items}->[$item_number]->{'QW'},
CL => $order{items}->[$item_number]->{'CL'},
CT => $order{items}->[$item_number]->{'CT'},
CR => $order{items}->[$item_number]->{'CR'},
CB => $order{items}->[$item_number]->{'CB'},
FILE => [ $order{items}->[$item_number]->{'File'} ],
], @std_hdr
);
_die "post_file_upload failed" unless ($res->is_success);
&debug($res->content);
my $t = XML::Twig->new();
$t->parse($res->content);
&check_status("post_file_upload", $t);
foreach $e ('SessionID', 'NextFileName') {
$order{$e} = &get_elt_text($t->root, $e);
}
}
sub get_order_confirm {
&log("get_order_confirm");
my $res = $ua->request(
GET &url("http", $labs{$lab_ID}->{HTTPServer},
$labs{$lab_ID}->{HTTPPath}."getlabinfo3.asp",
[
"OID" => $order{SessionID},
]
), @std_hdr
);
_die "get_order_confirm failed" unless ($res->is_success);
&debug($res->content);
my $t = XML::Twig->new();
$t->parse($res->content);
&check_status("get_order_confirm", $t);
print "\n***** Order summary *****\n";
print &get_elt_text($t->root, 'Information')."\n\n";
my @items = $t->root->first_child('ItemList')->children('Item');
foreach $i (@items) {
print "\n" if $i->is_empty;
print &get_elt_text($i,'Description').": ".
&get_elt_text($i,'UnitPrice')." x ".
&get_elt_text($i,'Quantity')." = ".
&get_elt_text($i,'Price')." $labs{$lab_ID}->{'Currency'}. Sent: ".
&get_elt_text($i,'Sent')."\n";
}
print "\n";
my @totals = $t->root->first_child('TotalList')->children('Item');
foreach $i (@totals) {
next if $i->is_empty;
print &get_elt_text($i,'Description').": ".
&get_elt_text($i,'Price')." $labs{$lab_ID}->{'Currency'}\n";
}
print "\n";
my $ord = $t->root->first_child('Order');
print "Order ID: " . &get_elt_text($ord, 'OrderID')."\n";
print "Amount: " . &get_elt_text($ord, 'Amount')." $labs{$lab_ID}->{'Currency'}\n";
print "Pay method: " . &get_elt_text($ord, 'PayMethod')."\n";
print "Ship method: " . &get_elt_text($ord, 'ShipMethod')."\n";
my $lab = $ord->first_child('Lab');
print "Lab address:\n";
print " ".&get_elt_text($lab, 'Name')."\n";
print " ".&get_elt_text($lab, 'Addr')."\n";
print " ".&get_elt_text($lab, 'Zip')." ".&get_elt_text($lab, 'City')."\n";
print " ".&get_elt_text($lab, 'Ctry')."\n";
print " Tel: ".&get_elt_text($lab, 'Tel')."\n";
print " Fax: ".&get_elt_text($lab, 'Fax')."\n";
print "Confirmed: " . (&get_elt_text($ord, 'Confirmed') == 1?"Yes":"No")."\n";
print &get_elt_text($ord, 'ClosingMessage')."\n";
}
sub save_xml_doc {
my ($file, $xml) = @_;
open(FILE, ">$file") || _die "Cannot open file $file for writing";
print FILE $xml;
close(FILE);
}
sub read_xml_doc {
my $file = shift(@_);
open(FILE, "$file") || _die "Cannot open file $file for reading";
$oldRS = $/;
undef $/;
my $xml = ;
$/ = $oldRS;
close(FILE);
return $xml;
}
sub write_fotowirerc {
open(RC,">$config_file");
print RC
"\# fotowirerc
\# Configuration file for fotowire
\# \%customer_info and \%card_info are Perl hashtables,
\# \$lab_ID and \$promo_code are Perl scalars.
\# Don't forget to escape the \@ in e-mail addresses!
\# \$lab_ID = \"1100\";
\# \$promo_code = \"\";
\%customer_info = (
Title => \"\",
FirstName => \"\",
LastName => \"\",
Address1 => \"\",
Address2 => \"\",
City => \"\",
StateOrProvince => \"\",
PostalCode => \"\",
CountryCode => \"FIN\",
PhoneNumber => \"\",
FaxNumber => \"\",
EmailAddress => \"\",
LabCustomerID => \"\",
DenyEmail => 1,
);
\%card_info = (
Number => \"\",
ExpirationMonth => \"\",
ExpirationYear => \"\",
OwnerName => \"\",
);
1;
";
close(RC);
}
#############################################################################
### Main
#############################################################################
&log_open();
mkdir($config_dir,0700) || _die "Cannot create config directory" unless -e $config_dir;
if (! -e $config_file) {
&write_fotowirerc();
_die "No config file found, I created an empty one.
Fill it before continuing";
}
else {
require "$config_file";
_die "Config file exists, but seems empty" unless $customer_info{'LastName'};
}
if ($DEBUG) {
$master = "localhost:8000";
if (exists $labs{$lab_ID}) {
$labs{$lab_ID}->{HTTPServer} = $master;
$labs{$lab_ID}->{HTTPPath} = "/";
}
}
else {
$master = "master.fotowire.com";
}
$ua = LWP::UserAgent->new;
$ua->agent("fwClient(3.0.0.123;ENU;1100) OS(5.0.2195;FIN;WinNT)".
" WinInet(5.0.2920.0) Browser(5.0.2920.0;;IE)");
$ua->protocols_allowed( [ 'http', 'ftp', 'https' ]);
# 1. Get a list of all labs
if (! -e $labs_xml ||
(-e $labs_xml &&
( &cmp_file_date($labs_xml,$config_file) < 0 ||
&file_too_old($labs_xml)
)
)
) {
&get_list_labs();
}
else {
&parse_list_labs(&read_xml_doc($labs_xml));
}
if (!$lab_ID) {
print "Please configure fotowire so that it uses one of the following labs:\n";
&print_list_labs();
}
else {
# 2. Get version (useless ?)
#&get_version();
# 3. Get info about the selected lab (products and prices)
&parse_lab_info(&read_xml_doc($labinfos_xml)) if (-e $labinfos_xml);
if (! -e $labinfos_xml ||
(-e $labinfos_xml &&
( &cmp_file_date($labinfos_xml,$config_file) < 0 ||
&file_too_old($labinfos_xml)
)
) ||
! exists $labs{$lab_ID}->{'Product'}
) {
# 3.1 Get the URL parameters for getting the info
if ($DEBUG) {
print "FAKE GET_LAB_URL\n";
$labs{$lab_ID}->{HTTPServer} = $master;
$labs{$lab_ID}->{HTTPPath} = "/";
}
else {
&get_lab_url();
}
# 3.2 Get the actual info
&get_lab_info();
}
if ($#ARGV == -1) {
print "\n***** Lab information *****\n";
&print_lab_basics($lab_ID);
&print_lab_paymethod($lab_ID);
&print_lab_products($lab_ID);
&print_lab_shipmethods($lab_ID);
exit (0);
}
}
if ($#ARGV == 1) {
_die "Order file $ARGV[1] does not exist !" unless -e $ARGV[1];
if ($ARGV[0] eq "check") {
# 4. Parse the order from user
&read_order_from_file($ARGV[1], 0);
}
elsif ($ARGV[0] eq "eval") {
if ($DEBUG) {
$labs{$lab_ID}->{HTTPServer} = $master;
$labs{$lab_ID}->{HTTPPath} = "/";
}
&read_order_from_file($ARGV[1], 1);
# 5. Post customer info
&post_customer_info(); # unless -e $session;
sleep (1);
# 6. Post order info for price evaluation
&post_order_evaluate ();
sleep (1);
}
elsif ($ARGV[0] eq "send") {
_die "No session found. Have you run 'fotowire.pl your_order' first?" unless -e $session;
require "$session";
&read_order_from_file($ARGV[1], 1);
if ($DEBUG) {
$labs{$lab_ID}->{HTTPServer} = $master;
$labs{$lab_ID}->{HTTPPath} = "/";
}
# 7. Post the start of order signal
&post_order_start();
sleep (1);
if ($DEBUG) {
$order{HTTPUplServer} = $master;
$order{HTTPUplPath} = "/";
}
# 8. Upload all the files
print "\n***** File upload *****\n";
my @items = $order{items};
for($i=0; $i <= $#items; $i++) {
print "Sending item $i: $order{items}->[$i]->{'File'}\n";
&post_file_upload($i);
sleep (1);
}
print "All files uploaded!\n";
# 9. Get the confirmation of the order
&get_order_confirm();
unlink($session);
}
else {
print STDERR "Usage: fotowire.pl your_order {check|eval|send}\n";
_die "Incorrect syntax";
}
}
else {
print STDERR "Usage: fotowire.pl\n fotowire.pl your_order {check|eval|send}\n";
_die "Incorrect syntax";
}
&log_close()