Download the file
  1. #!/usr/bin/perl -w
  2.  
  3. # This is fotowire.pl version 0.1, a free implementation of the FotoWire
  4. # protocol and command-line client.
  5. # Copyright (c) 2003 Matthieu Weber
  6. #
  7. # This program is free software; you can redistribute it and/or modify it
  8. # under the terms of the GNU General Public License as published by the Free
  9. # Software Foundation; either version 2 of the License, or (at your option)
  10. # any later version.
  11. #
  12. # This program is distributed in the hope that it will be useful, but WITHOUT
  13. # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
  15. # more details.
  16. #
  17. # You should have received a copy of the GNU General Public License along with
  18. # this program; if not, write to the Free Software Foundation, Inc., 59 Temple
  19. # Place - Suite 330, Boston, MA 02111-1307, USA.
  20. # Or, point your browser to http://www.gnu.org/copyleft/gpl.html
  21. #
  22. # Author: Matthieu Weber
  23. # E-mail: mweber@mit.jyu.fi
  24.  
  25. $DEBUG = 0;
  26.  
  27. $min_print_res = 150; # in dots/in
  28. $config_dir = "$ENV{HOME}/.fotowire";
  29. $config_file = "$config_dir/fotowirerc";
  30. $session = "$config_dir/session";
  31. $log_file = "$config_dir/log";
  32. $debug_file = "$config_dir/debug";
  33. $labs_xml = "$config_dir/labs.xml";
  34. $labinfos_xml = "$config_dir/labinfos.xml";
  35. $file_max_age = 86400; # in seconds
  36.  
  37.  
  38. use HTTP::Request::Common;
  39. use LWP::UserAgent;
  40. use URI;
  41. use XML::Twig;
  42. use Unicode::MapUTF8 qw(from_utf8);
  43. use Image::Info qw(image_info dim);
  44.  
  45. my @std_hdr = (
  46. 'Connection' => 'Keep-Alive',
  47. 'Accept-Language' => 'en',
  48. );
  49.  
  50. sub get_elt_text {
  51. my ($node, $gi) = @_;
  52. return from_utf8(-string => $node->first_child($gi)->text,
  53. -charset => 'ISO-8859-1');
  54. }
  55.  
  56. sub cmp_file_date {
  57. # returns -1 if f1 less recent than f2
  58. # 0 if f1 as recent as f2
  59. # 1 if f1 more recent than f2
  60. my ($f1, $f2) = @_;
  61. return (stat($f1))[9] <=> (stat($f2))[9];
  62. }
  63.  
  64. sub file_too_old {
  65. my $f = shift(@_);
  66. return (stat($f))[9] + $file_max_age < time();
  67. }
  68.  
  69. sub log_open {
  70. open(LOG,">>$log_file");
  71. $log_opened = 1;
  72. }
  73.  
  74. sub log_close {
  75. $log_opened = 0;
  76. close(LOG);
  77. }
  78.  
  79. sub log {
  80. my $s = shift(@_);
  81. if ($log_opened) {
  82. my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
  83. printf LOG "%04d/%02d/%02d %02d:%02d:%02d %s\n",
  84. $year+1900, $mon+1, $mday, $hour, $min, $sec, $s;
  85. }
  86. else {
  87. print STDERR "Log file is not opened!\n";
  88. }
  89. }
  90.  
  91. sub debug {
  92. my $s = shift(@_);
  93. open(DEBUG, ">>$debug_file");
  94. print DEBUG localtime(time)."\n";
  95. print DEBUG "$s\n\n";
  96. close(DEBUG);
  97. }
  98.  
  99. sub _die {
  100. my $s = shift(@_);
  101. print STDERR "$s. Exit.\n";
  102. &log("DIED $s");
  103. &log_close();
  104. exit(1);
  105. }
  106.  
  107. sub code_url_param {
  108. my $s = shift(@_);
  109. $s =~ s/ /+/g;
  110. $s =~ s/[^A-Za-z0-9-]/sprintf("%%%x")/eg;
  111. return $s;
  112. }
  113.  
  114.  
  115. sub url {
  116. my ($scheme, $authority, $path, $query) = @_;
  117. my $u = URI->new;
  118. $u->scheme($scheme);
  119. $u->authority($authority);
  120. $u->path($path) if defined $path;
  121. $u->query_form(@{$query}) if defined $query;
  122. return $u->as_string();
  123. }
  124.  
  125. sub check_status {
  126. my ($fun_name, $t) = @_;
  127. if ($t->root->first_child('Status')) {
  128. my $status = $t->root->first_child('Status')->first_child('Code')->text;
  129. if ($status != 0) {
  130. _die "$fun_name status = $status".": ".
  131. &get_elt_text($t->root->first_child('Status'), 'Description');
  132. }
  133. }
  134. }
  135.  
  136. sub get_list_labs {
  137. &log("get_list_labs");
  138. my $req = GET &url("http",$master, "/fworder/listlabs3.asp",
  139. [
  140. "CN" => $customer_info{CountryCode},
  141. ]
  142. ),
  143. @std_hdr;
  144. my $res = $ua->request($req);
  145. _die "get_list_labs failed" unless ($res->is_success);
  146. &save_xml_doc($labs_xml, $res->content);
  147. &parse_list_labs($res->content);
  148. }
  149.  
  150. sub parse_list_labs {
  151. my $doc = shift(@_);
  152. my $t = XML::Twig->new();
  153. $t->parse($doc);
  154. my @lablist = $t->root->children('Lab');
  155. foreach $lab (@lablist) {
  156. my $id = &get_elt_text($lab,'ID');
  157. foreach $e ('Name', 'Addr', 'City', 'State', 'Zip', 'Ctry',
  158. 'Tel', 'Fax', 'TargetCtry', 'InfoURL', 'Opt') {
  159. $labs{$id}->{$e} = &get_elt_text($lab,$e);
  160. }
  161. }
  162. }
  163.  
  164. sub print_list_labs {
  165. print "\n***** Labs *****\n";
  166. foreach $l (sort {
  167. my $l1 = $labs{$a}->{Ctry} cmp $labs{$b}->{Ctry};
  168. if ($l1 == 0) {
  169. $labs{$a}->{Name} cmp $labs{$b}->{Name};
  170. }
  171. else {
  172. $l1;
  173. }
  174. } keys(%labs)) {
  175. printf " %6d: [$labs{$l}->{Ctry}] $labs{$l}->{Name}, $labs{$l}->{City}\n", $l;
  176. }
  177. print "\n";
  178. }
  179.  
  180. sub get_version {
  181. &log("get_version");
  182. my $res = $ua->request(
  183. GET &url("http", $master, "/fworder/fwver.asp",
  184. [
  185. "LID" => $lab_ID,
  186. "OEM" => $lab_ID,
  187. "UPID"=> $lab_ID,
  188. "VER" => '3.0.0.123',
  189. "RD" => '98cc3',
  190. ]),
  191. @std_hdr,
  192. );
  193. }
  194.  
  195. sub get_lab_url {
  196. &log("get_lab_url");
  197. my $req = GET &url("http", $master, "/fworder/getlaburl.asp",
  198. [
  199. "LID" => $lab_ID,
  200. "RD" => '98d5a',
  201. ]
  202. ),
  203. @std_hdr;
  204. my $res = $ua->request($req);
  205. _die "get_lab_url failed" unless ($res->is_success);
  206. my $t = XML::Twig->new();
  207. $t->parse($res->content);
  208. &check_status("get_lab_url", $t);
  209. my @lablist = $t->root->children('Lab');
  210. foreach $lab (@lablist) {
  211. my $id = &get_elt_text($lab,'ID');
  212. foreach $e ('HTTPServer', 'HTTPPath') {
  213. $labs{$id}->{$e} = &get_elt_text($lab, $e);
  214. }
  215. }
  216. }
  217.  
  218. sub get_lab_info {
  219. &log("get_lab_info");
  220. my @content = (
  221. "LID" => $lab_ID,
  222. "DID" => '',
  223. "RD" => '98d96',
  224. );
  225. push @content, ( PROMO => $promo_code) if $promo_code;
  226.  
  227. my $res = $ua->request(
  228. GET &url("http", $labs{$lab_ID}->{HTTPServer},
  229. $labs{$lab_ID}->{HTTPPath}."getlabinfo3.asp",
  230. \@content,
  231. ),
  232. @std_hdr
  233. );
  234. _die "get_lab_info failed" unless ($res->is_success);
  235. &save_xml_doc($labinfos_xml, $res->content);
  236. &parse_lab_info($res->content);
  237. }
  238.  
  239. sub parse_lab_info {
  240. my $xml = shift(@_);
  241. my $t = XML::Twig->new();
  242. $t->parse($xml);
  243. my @lablist = $t->root->children('Lab');
  244. foreach $lab (@lablist) {
  245. my $lid = &get_elt_text($lab, 'ID');
  246. foreach $e ('Name', 'Addr', 'City', 'State', 'Zip', 'Ctry',
  247. 'Tel', 'Fax', 'TargetCtry', 'InfoURL', 'HTTPServer',
  248. 'HTTPPath', 'Currency', 'TaxInfoMsg', 'InfoMsg',
  249. 'Opt', 'InfoMsgWeb', 'Validity', 'MinOrder') {
  250. next unless $lab->first_child($e);
  251. $labs{$lid}->{$e} = &get_elt_text($lab, $e);
  252. }
  253. my @pml = $lab->first_child('PayMethodList')->children('PayMethod');
  254. foreach $pm (@pml) {
  255. my $id = &get_elt_text($pm, 'ID');
  256. foreach $e ('Description', 'Explanation', 'CardType') {
  257. $labs{$lid}->{'PayMethod'}->{$id}->{$e} = &get_elt_text($pm, $e);
  258. }
  259. }
  260. my @pl = $lab->first_child('ProductList')->children('Product');
  261. foreach $p (@pl) {
  262. my $id = &get_elt_text($p,'ID');
  263. foreach $e ('Description', 'UnitPriceN', 'MinImageXRes', 'MinImageYRes',
  264. 'SizeX', 'SizeY') {
  265. $labs{$lid}->{'Product'}->{$id}->{$e} = &get_elt_text($p, $e);
  266. }
  267. }
  268. my @sml = $lab->first_child('ShipMethodList')->children('ShipMethod');
  269. foreach $sm (@sml) {
  270. my $id = &get_elt_text($sm,'ID');
  271. foreach $e ('Description', 'PriceN') {
  272. $labs{$lid}->{'ShipMethod'}->{$id}->{$e} = &get_elt_text($sm, $e);
  273. }
  274. }
  275. }
  276. }
  277.  
  278. sub print_lab_basics {
  279. my $lid = shift(@_);
  280. print "Information for $labs{$lid}->{'Name'} ($lid):\n";
  281. print " $labs{$lid}->{'Name'}\n";
  282. print " $labs{$lid}->{'Addr'}\n";
  283. print " $labs{$lid}->{'Zip'} $labs{$lid}->{'City'}\n";
  284. print " $labs{$lid}->{'Ctry'}\n";
  285. print " Tel: $labs{$lid}->{'Tel'}\n";
  286. print " Fax: $labs{$lid}->{'Fax'}\n";
  287. print "\n";
  288. print "$labs{$lid}->{'MinOrder'}\n" if $labs{$lid}->{'MinOrder'};
  289. print "$labs{$lid}->{'InfoMsg'}\n" if $labs{$lid}->{'TaxInfoMsg'};
  290. print "$labs{$lid}->{'TaxInfoMsg'}\n" if $labs{$lid}->{'TaxInfoMsg'};
  291. print "$labs{$lid}->{'InfoMsgWeb'}\n" if $labs{$lid}->{'TaxInfoMsg'};
  292. print "\n";
  293.  
  294. }
  295.  
  296. sub print_lab_paymethod {
  297. my $lid = shift(@_);
  298. my %paymethod = %{$labs{$lid}->{'PayMethod'}};
  299. print "Pay methods for $labs{$lid}->{'Name'} ($lid):\n";
  300. foreach $id (keys(%paymethod)) {
  301. printf " %4d: %s (%s)", $id, $paymethod{$id}->{Description}, $paymethod{$id}->{Explanation};
  302. printf " [%s]", $paymethod{$id}->{CardType} if $paymethod{$id}->{CardType};
  303. print "\n";
  304. }
  305. print "\n";
  306. }
  307.  
  308. sub print_lab_products {
  309. my $lid = shift(@_);
  310. my %product = %{$labs{$lid}->{'Product'}};
  311. print "Products for $labs{$lid}->{Name} ($lid):\n";
  312. foreach $id (sort {$product{$a}->{Description} cmp $product{$b}->{Description}} keys(%product)) {
  313. printf " %4d: %-40s (> %4d x %4d) %5.2f %s \n", $id, $product{$id}->{Description},
  314. $product{$id}->{'MinImageXRes'}, $product{$id}->{'MinImageYRes'},
  315. $product{$id}->{'UnitPriceN'}, $labs{$lid}->{'Currency'};
  316. }
  317. print "\n";
  318. }
  319.  
  320. sub print_lab_shipmethods {
  321. my $lid = shift(@_);
  322. my %shipmethod = %{$labs{$lid}->{'ShipMethod'}};
  323. print "Ship methods for $labs{$lid}->{Name} ($lid):\n";
  324. foreach $id (keys(%shipmethod)) {
  325. printf " %4d: %-40s %s %s\n", $id, $shipmethod{$id}->{Description},
  326. $shipmethod{$id}->{PriceN}, $labs{$lid}->{'Currency'};
  327. }
  328. print "\n";
  329. }
  330.  
  331. sub post_customer_info {
  332. &log("post_customer_info");
  333. my @content = (
  334. LID => $lab_ID,
  335. CID => 0,
  336. PW => '',
  337. );
  338. foreach $key (keys(%customer_info)) {
  339. push @content, ($key => $customer_info{$key});
  340. }
  341.  
  342. my $req= POST &url("http", $labs{$lab_ID}->{HTTPServer},
  343. $labs{$lab_ID}->{HTTPPath}."customerset3.asp"),
  344. \@content,
  345. @std_hdr;
  346. my $res = $ua->request($req);
  347. _die "post_customer_info failed" unless ($res->is_success);
  348. my $t = XML::Twig->new();
  349. $t->parse($res->content);
  350. &check_status("post_customer_info", $t);
  351. open(SESSION,">$session") || _die "Cannot open session file $session";
  352. foreach $e ('ID', 'PW') {
  353. $customer_info{$e} = &get_elt_text($t->root->first_child('Customer'), $e);
  354. print SESSION "\$customer_info{$e} = $customer_info{$e};\n";
  355. }
  356. print SESSION "1;\n";
  357. close(SESSION);
  358. }
  359.  
  360. sub get_img_dim {
  361. my ($file) = @_;
  362. my $info = image_info($file);
  363. _die "Cannot parse image info: $info->{error}" if $info->{error};
  364. return dim($info);
  365. }
  366.  
  367. sub eval_resolution {
  368. # This function is awful, and can probably be optimized
  369. # For now, we'll do with the comments
  370. my ($x, $y, $paper_x, $paper_y, $crop) = @_;
  371.  
  372. # By default, we suppose the image and the paper are horizontal (landscape)
  373. my $img_horiz = 1;
  374. my $pap_horiz = 1;
  375.  
  376. # Ratio of the sides of the image
  377. my $img_rap = $x / $y;
  378. if ($img_rap < 1) {
  379. # We want a number > 1
  380. $img_rap = 1 / $img_rap;
  381. # However, if the number was < 1, we know the image/paper was vertical
  382. # (portrait)
  383. $img_horiz = 0;
  384. }
  385. # And we want only 3 significative digits.
  386. $img_rap = int (100 * $img_rap) / 100;
  387.  
  388. # Same as above, but with the paper
  389. my $pap_rap = $paper_x / $paper_y;
  390. if ($pap_rap < 1) {
  391. $pap_rap = 1 / $pap_rap;
  392. $pap_horiz = 0;
  393. }
  394. $pap_rap = int (100 * $pap_rap) / 100;
  395.  
  396. # The ratio of the image length over paper length gives the horizontal
  397. # resolution. If one element was vertical and the other horizontal, we need
  398. # to swap the length and height of one of the elements.
  399. my $x_res = int(25.4 * $x / ($pap_horiz == $img_horiz ? $paper_x : $paper_y));
  400. # Same with vertical resolution
  401. my $y_res = int(25.4 * $y / ($pap_horiz == $img_horiz ? $paper_y : $paper_x));
  402.  
  403.  
  404. if ($img_horiz) {
  405. # If the image is horizontal, then the white bands are on the sides,
  406. # and the crop area is on top/bottom
  407. $crop_side = "top/bottom";
  408. $white_bands = "left/right";
  409. }
  410. else {
  411. # Inverse of the above if the image is vertical
  412. $crop_side = "left/right";
  413. $white_bands = "top/bottom";
  414. }
  415.  
  416. if ($img_rap < $pap_rap) {
  417. # If the image ratio is lower than the paper ratio (i.e. 4:3 image in a
  418. # 3:2 paper), and if the image is cropped and if the image is horizontal,
  419. # then the image resolution is x_res; otherwise it is y_res
  420. return $crop ? ($img_horiz ? $x_res : $y_res, "cropped ".$crop_side) : ($img_horiz ? $y_res : $x_res, "white bands ".$white_bands);
  421. }
  422. elsif ($img_rap == $pap_rap) {
  423. # This is if the image fits perfectly the paper
  424. return ($x_res, "");
  425. }
  426. else {
  427. # This is unlikely to happen (unless we put a panorama image in a 4:3
  428. # or 3:2 paper)
  429. return $crop ? ($img_horiz ? $y_res : $x_res, "cropped".$crop_side) : ($img_horiz ? $x_res : $y_res, "white bands".$white_bands);
  430. }
  431. }
  432.  
  433. sub read_order_from_file {
  434. &log("read_order_from_file");
  435. my $order_file = shift(@_);
  436. my $silent = shift(@_);
  437. open(ORDER,"$order_file") || _die "Cannot open order $order_file";
  438. my $header = 1;
  439. my $line_count = 1;
  440. my $item_count = 0;
  441. print "\n***** Your order *****\n" unless $silent;
  442. while(<ORDER>) {
  443. s/\r?\n//;
  444. if ($header) {
  445. if ($_ eq "") {
  446. $header = 0;
  447. print "Items:\n" unless $silent;
  448. }
  449. else {
  450. my ($k, $v) = split(/\s+/);
  451. if ($k =~ /ShipMethod|PayMethod/ && $v =~ /\d+/) {
  452. $order{$k} = $v;
  453. _die "Illegal value for $k in $order_file, line $line_count" unless exists $labs{$lab_ID}->{$k}->{$v};
  454. print "$k: $labs{$lab_ID}->{$k}->{$v}->{'Description'}\n" unless $silent;
  455. }
  456. else {
  457. _die "Syntax error in $order_file, line $line_count";
  458. }
  459. }
  460. }
  461. else {
  462. my ($pid, $qty, $file) = (/^(\S+)\s+(\S+)\s+(.*)$/);
  463. _die "Product ID '$pid' is not a number in $order_file, line $line_count" unless $pid =~ /^\d+$/;
  464. _die "Quantity '$qty' is not a number in $order_file, line $line_count" unless $qty =~ /^\d+$/;
  465. my $opts = "";
  466. ($file, $opts, $opts_arg) = ($1, $2, $3) if ($file =~ /(.*) (crop|nocrop) ?(.*)$/);
  467. my ($x, $y) = &get_img_dim($file);
  468. _die "File $file does not exist in $order_file, line $line_count" unless -e $file;
  469. _die "Product $pid does not exist in $order_file, line $line_count" unless exists $labs{$lab_ID}->{'Product'}->{$pid};
  470. _die "Option $opts does not exist in $order_file, line $line_count" unless $opts =~ /^crop$|^nocrop$/ || $opts eq "";
  471. my ($min_x, $min_y) = ($labs{$lab_ID}->{'Product'}->{$pid}->{'MinImageXRes'},
  472. $labs{$lab_ID}->{'Product'}->{$pid}->{'MinImageYRes'});
  473. ($min_x, $min_y) = ($min_y, $min_x) if (($x < $y) && ($min_x > $min_y)) || (($x > $y) && ($min_x < $min_y));
  474. _die sprintf "The resolution of file %s (%d x %d) is below the limit for the chosen format (%d x %d)",
  475. $file, $x, $y, $min_x, $min_y if $x < $min_x || $y < $min_y;
  476. $order{items}->[$item_count]->{'ProductID'} = $pid;
  477. $order{items}->[$item_count]->{'Quantity'} = $qty;
  478. $order{items}->[$item_count]->{'File'} = $file;
  479. $order{items}->[$item_count]->{'X'} = $x;
  480. $order{items}->[$item_count]->{'Y'} = $x;
  481. my ($res, $aspect) = eval_resolution($x, $y, $labs{$lab_ID}->{'Product'}->{$pid}->{'SizeY'},
  482. $labs{$lab_ID}->{'Product'}->{$pid}->{'SizeX'},
  483. $opts eq "crop" ? 1 : 0);
  484. printf " %2d x %-35s [%-35s]\n Res: %d dpi %s%s\n\n",
  485. $qty, $file, $labs{$lab_ID}->{'Product'}->{$pid}->{'Description'},
  486. $res, $res < $min_print_res ? "LOW RES ":"", $aspect unless $silent;
  487. $order{items}->[$item_count]->{'CT'} = 1;
  488. $order{items}->[$item_count]->{'CB'} = 1;
  489. $order{items}->[$item_count]->{'CL'} = 1;
  490. $order{items}->[$item_count]->{'CR'} = 1;
  491. $order{items}->[$item_count]->{'QW'} = 1;
  492. $order{items}->[$item_count]->{'FC'} = 0;
  493. $item_count ++;
  494. }
  495. $line_count ++;
  496. }
  497. close(ORDER);
  498. _die "Order is empty!" unless exists $order{items};
  499. }
  500.  
  501. sub post_order_evaluate {
  502. &log("post_order_evaluate");
  503. my @content = (
  504. LID => $lab_ID,
  505. CID => $customer_info{ID},
  506. CPW => $customer_info{PW},
  507. SID => $order{ShipMethod},
  508. AID => $order{PayMethod},
  509. OEM => $lab_ID,
  510. );
  511. foreach $item (@{$order{items}}) {
  512. push @content, (
  513. PID => $item->{ProductID},
  514. Q => $item->{Quantity}
  515. );
  516. }
  517.  
  518. my $req = POST &url("http", $labs{$lab_ID}->{HTTPServer},
  519. $labs{$lab_ID}->{HTTPPath}."orderevaluate3.asp"),
  520. \@content,
  521. @std_hdr;
  522. &debug($req->as_string());
  523. my $res = $ua->request($req);
  524. _die "post_order_evaluate failed" unless ($res->is_success);
  525. &debug($res->as_string);
  526. my $t = XML::Twig->new();
  527. $t->parse($res->content);
  528. &check_status("post_order_evaluate", $t);
  529. print "\n***** Order evaluation *****\n";
  530. print &get_elt_text($t->root, 'Information')."\n\n";
  531. my @items = $t->root->first_child('ItemList')->children('Item');
  532. foreach $i (@items) {
  533. print "\n",next if $i->is_empty;
  534. print &get_elt_text($i,'Description').": ".
  535. &get_elt_text($i,'UnitPrice')." x ".
  536. &get_elt_text($i,'Quantity')." = ".
  537. &get_elt_text($i,'Price')." $labs{$lab_ID}->{'Currency'}\n";
  538. }
  539. print "\n";
  540. my @totals = $t->root->first_child('TotalList')->children('Item');
  541. foreach $i (@totals) {
  542. print "\n",next if $i->is_empty;
  543. print &get_elt_text($i,'Description').": ".
  544. &get_elt_text($i,'Price')." $labs{$lab_ID}->{'Currency'}\n";
  545. }
  546. }
  547.  
  548. sub post_order_start {
  549. &log("post_order_start");
  550. my $proto = 'http';
  551. my $pay_by_card = $labs{$lab_ID}->{PayMethod}->{$order{PayMethod}}->{CardType} eq ''?0:1;
  552. $proto = 'https' if $pay_by_card;
  553.  
  554. my @content = (
  555. LID => $lab_ID,
  556. CID => $customer_info{ID},
  557. CPW => $customer_info{PW},
  558. SID => $order{ShipMethod},
  559. AID => $order{PayMethod},
  560. OEM => $lab_ID,
  561. );
  562. if ($pay_by_card) {
  563. push @content, (
  564. CN => $card_info{Number},
  565. CEM => $card_info{ExpirationMonth},
  566. CEY => $card_info{ExpirationYear},
  567. CO => $card_info{OwnerName},
  568. );
  569. }
  570. else {
  571. push @content, (
  572. CN => '',
  573. CEM => '',
  574. CEY => '',
  575. CO => ''
  576. );
  577. }
  578. my $req= POST &url($proto, $labs{$lab_ID}->{HTTPServer},
  579. $labs{$lab_ID}->{HTTPPath}."orderstart3.asp"),
  580. \@content, @std_hdr;
  581. my $res = $ua->request($req);
  582. _die "post_order_start failed" unless ($res->is_success);
  583. &debug($res->content);
  584. my $t = XML::Twig->new();
  585. $t->parse($res->content);
  586. &check_status("post_order_start", $t);
  587. foreach $e ('SessionID', 'NextFileName', 'HTTPUplServer', 'HTTPUplPath',
  588. 'FTPServer', 'FTPPath') {
  589. $order{$e} = &get_elt_text($t->root,$e);
  590. }
  591. }
  592.  
  593. sub post_file_upload {
  594. &log("post_file_upload");
  595. my $item_number = shift(@_);
  596. my $res = $ua->request(
  597. POST &url("http", $order{HTTPUplServer},
  598. $order{HTTPUplPath}."newimage3.asp"),
  599. Content_Type => 'form-data',
  600. Content => [
  601. SRV => $labs{$lab_ID}->{HTTPServer},
  602. PATH => $labs{$lab_ID}->{HTTPPath},
  603. OID => $order{SessionID},
  604. PID => $order{items}->[$item_number]->{'ProductID'},
  605. Q => $order{items}->[$item_number]->{'Quantity'},
  606. FS => (stat($order{items}->[$item_number]->{'File'}))[7],
  607. FC => $order{items}->[$item_number]->{'FC'},
  608. IX => $order{items}->[$item_number]->{'X'},
  609. IY => $order{items}->[$item_number]->{'Y'},
  610. QW => $order{items}->[$item_number]->{'QW'},
  611. CL => $order{items}->[$item_number]->{'CL'},
  612. CT => $order{items}->[$item_number]->{'CT'},
  613. CR => $order{items}->[$item_number]->{'CR'},
  614. CB => $order{items}->[$item_number]->{'CB'},
  615. FILE => [ $order{items}->[$item_number]->{'File'} ],
  616. ], @std_hdr
  617. );
  618. _die "post_file_upload failed" unless ($res->is_success);
  619. &debug($res->content);
  620. my $t = XML::Twig->new();
  621. $t->parse($res->content);
  622. &check_status("post_file_upload", $t);
  623. foreach $e ('SessionID', 'NextFileName') {
  624. $order{$e} = &get_elt_text($t->root, $e);
  625. }
  626. }
  627.  
  628. sub get_order_confirm {
  629. &log("get_order_confirm");
  630. my $res = $ua->request(
  631. GET &url("http", $labs{$lab_ID}->{HTTPServer},
  632. $labs{$lab_ID}->{HTTPPath}."getlabinfo3.asp",
  633. [
  634. "OID" => $order{SessionID},
  635. ]
  636. ), @std_hdr
  637. );
  638. _die "get_order_confirm failed" unless ($res->is_success);
  639. &debug($res->content);
  640. my $t = XML::Twig->new();
  641. $t->parse($res->content);
  642. &check_status("get_order_confirm", $t);
  643. print "\n***** Order summary *****\n";
  644. print &get_elt_text($t->root, 'Information')."\n\n";
  645. my @items = $t->root->first_child('ItemList')->children('Item');
  646. foreach $i (@items) {
  647. print "\n" if $i->is_empty;
  648. print &get_elt_text($i,'Description').": ".
  649. &get_elt_text($i,'UnitPrice')." x ".
  650. &get_elt_text($i,'Quantity')." = ".
  651. &get_elt_text($i,'Price')." $labs{$lab_ID}->{'Currency'}. Sent: ".
  652. &get_elt_text($i,'Sent')."\n";
  653. }
  654. print "\n";
  655. my @totals = $t->root->first_child('TotalList')->children('Item');
  656. foreach $i (@totals) {
  657. next if $i->is_empty;
  658. print &get_elt_text($i,'Description').": ".
  659. &get_elt_text($i,'Price')." $labs{$lab_ID}->{'Currency'}\n";
  660. }
  661. print "\n";
  662. my $ord = $t->root->first_child('Order');
  663. print "Order ID: " . &get_elt_text($ord, 'OrderID')."\n";
  664. print "Amount: " . &get_elt_text($ord, 'Amount')." $labs{$lab_ID}->{'Currency'}\n";
  665. print "Pay method: " . &get_elt_text($ord, 'PayMethod')."\n";
  666. print "Ship method: " . &get_elt_text($ord, 'ShipMethod')."\n";
  667. my $lab = $ord->first_child('Lab');
  668. print "Lab address:\n";
  669. print " ".&get_elt_text($lab, 'Name')."\n";
  670. print " ".&get_elt_text($lab, 'Addr')."\n";
  671. print " ".&get_elt_text($lab, 'Zip')." ".&get_elt_text($lab, 'City')."\n";
  672. print " ".&get_elt_text($lab, 'Ctry')."\n";
  673. print " Tel: ".&get_elt_text($lab, 'Tel')."\n";
  674. print " Fax: ".&get_elt_text($lab, 'Fax')."\n";
  675. print "Confirmed: " . (&get_elt_text($ord, 'Confirmed') == 1?"Yes":"No")."\n";
  676. print &get_elt_text($ord, 'ClosingMessage')."\n";
  677. }
  678.  
  679. sub save_xml_doc {
  680. my ($file, $xml) = @_;
  681. open(FILE, ">$file") || _die "Cannot open file $file for writing";
  682. print FILE $xml;
  683. close(FILE);
  684. }
  685.  
  686. sub read_xml_doc {
  687. my $file = shift(@_);
  688. open(FILE, "$file") || _die "Cannot open file $file for reading";
  689. $oldRS = $/;
  690. undef $/;
  691. my $xml = <FILE>;
  692. $/ = $oldRS;
  693. close(FILE);
  694. return $xml;
  695. }
  696.  
  697. sub write_fotowirerc {
  698. open(RC,">$config_file");
  699. print RC
  700. "\# fotowirerc
  701. \# Configuration file for fotowire
  702. \# \%customer_info and \%card_info are Perl hashtables,
  703. \# \$lab_ID and \$promo_code are Perl scalars.
  704. \# Don't forget to escape the \@ in e-mail addresses!
  705.  
  706. \# \$lab_ID = \"1100\";
  707. \# \$promo_code = \"\";
  708.  
  709. \%customer_info = (
  710. Title => \"\",
  711. FirstName => \"\",
  712. LastName => \"\",
  713. Address1 => \"\",
  714. Address2 => \"\",
  715. City => \"\",
  716. StateOrProvince => \"\",
  717. PostalCode => \"\",
  718. CountryCode => \"FIN\",
  719. PhoneNumber => \"\",
  720. FaxNumber => \"\",
  721. EmailAddress => \"\",
  722. LabCustomerID => \"\",
  723. DenyEmail => 1,
  724. );
  725.  
  726. \%card_info = (
  727. Number => \"\",
  728. ExpirationMonth => \"\",
  729. ExpirationYear => \"\",
  730. OwnerName => \"\",
  731. );
  732.  
  733. 1;
  734. ";
  735. close(RC);
  736. }
  737.  
  738. #############################################################################
  739. ### Main
  740. #############################################################################
  741.  
  742. &log_open();
  743. mkdir($config_dir,0700) || _die "Cannot create config directory" unless -e $config_dir;
  744.  
  745. if (! -e $config_file) {
  746. &write_fotowirerc();
  747. _die "No config file found, I created an empty one.
  748. Fill it before continuing";
  749. }
  750. else {
  751. require "$config_file";
  752. _die "Config file exists, but seems empty" unless $customer_info{'LastName'};
  753. }
  754.  
  755. if ($DEBUG) {
  756. $master = "localhost:8000";
  757. if (exists $labs{$lab_ID}) {
  758. $labs{$lab_ID}->{HTTPServer} = $master;
  759. $labs{$lab_ID}->{HTTPPath} = "/";
  760. }
  761. }
  762. else {
  763. $master = "master.fotowire.com";
  764. }
  765.  
  766. $ua = LWP::UserAgent->new;
  767. $ua->agent("fwClient(3.0.0.123;ENU;1100) OS(5.0.2195;FIN;WinNT)".
  768. " WinInet(5.0.2920.0) Browser(5.0.2920.0;;IE)");
  769. $ua->protocols_allowed( [ 'http', 'ftp', 'https' ]);
  770.  
  771. # 1. Get a list of all labs
  772. if (! -e $labs_xml ||
  773. (-e $labs_xml &&
  774. ( &cmp_file_date($labs_xml,$config_file) < 0 ||
  775. &file_too_old($labs_xml)
  776. )
  777. )
  778. ) {
  779. &get_list_labs();
  780. }
  781. else {
  782. &parse_list_labs(&read_xml_doc($labs_xml));
  783. }
  784. if (!$lab_ID) {
  785. print "Please configure fotowire so that it uses one of the following labs:\n";
  786. &print_list_labs();
  787. }
  788. else {
  789. # 2. Get version (useless ?)
  790. #&get_version();
  791.  
  792. # 3. Get info about the selected lab (products and prices)
  793. &parse_lab_info(&read_xml_doc($labinfos_xml)) if (-e $labinfos_xml);
  794. if (! -e $labinfos_xml ||
  795. (-e $labinfos_xml &&
  796. ( &cmp_file_date($labinfos_xml,$config_file) < 0 ||
  797. &file_too_old($labinfos_xml)
  798. )
  799. ) ||
  800. ! exists $labs{$lab_ID}->{'Product'}
  801. ) {
  802. # 3.1 Get the URL parameters for getting the info
  803. if ($DEBUG) {
  804. print "FAKE GET_LAB_URL\n";
  805. $labs{$lab_ID}->{HTTPServer} = $master;
  806. $labs{$lab_ID}->{HTTPPath} = "/";
  807. }
  808. else {
  809. &get_lab_url();
  810. }
  811. # 3.2 Get the actual info
  812. &get_lab_info();
  813. }
  814.  
  815. if ($#ARGV == -1) {
  816. print "\n***** Lab information *****\n";
  817. &print_lab_basics($lab_ID);
  818. &print_lab_paymethod($lab_ID);
  819. &print_lab_products($lab_ID);
  820. &print_lab_shipmethods($lab_ID);
  821. exit (0);
  822. }
  823. }
  824. if ($#ARGV == 1) {
  825. _die "Order file $ARGV[1] does not exist !" unless -e $ARGV[1];
  826. if ($ARGV[0] eq "check") {
  827. # 4. Parse the order from user
  828. &read_order_from_file($ARGV[1], 0);
  829. }
  830. elsif ($ARGV[0] eq "eval") {
  831. if ($DEBUG) {
  832. $labs{$lab_ID}->{HTTPServer} = $master;
  833. $labs{$lab_ID}->{HTTPPath} = "/";
  834. }
  835.  
  836. &read_order_from_file($ARGV[1], 1);
  837. # 5. Post customer info
  838. &post_customer_info(); # unless -e $session;
  839. sleep (1);
  840.  
  841. # 6. Post order info for price evaluation
  842. &post_order_evaluate ();
  843. sleep (1);
  844. }
  845. elsif ($ARGV[0] eq "send") {
  846. _die "No session found. Have you run 'fotowire.pl your_order' first?" unless -e $session;
  847. require "$session";
  848. &read_order_from_file($ARGV[1], 1);
  849. if ($DEBUG) {
  850. $labs{$lab_ID}->{HTTPServer} = $master;
  851. $labs{$lab_ID}->{HTTPPath} = "/";
  852. }
  853. # 7. Post the start of order signal
  854. &post_order_start();
  855. sleep (1);
  856. if ($DEBUG) {
  857. $order{HTTPUplServer} = $master;
  858. $order{HTTPUplPath} = "/";
  859. }
  860.  
  861. # 8. Upload all the files
  862. print "\n***** File upload *****\n";
  863. my @items = $order{items};
  864. for($i=0; $i <= $#items; $i++) {
  865. print "Sending item $i: $order{items}->[$i]->{'File'}\n";
  866. &post_file_upload($i);
  867. sleep (1);
  868. }
  869. print "All files uploaded!\n";
  870.  
  871. # 9. Get the confirmation of the order
  872. &get_order_confirm();
  873. unlink($session);
  874. }
  875. else {
  876. print STDERR "Usage: fotowire.pl your_order {check|eval|send}\n";
  877. _die "Incorrect syntax";
  878. }
  879. }
  880. else {
  881. print STDERR "Usage: fotowire.pl\n fotowire.pl your_order {check|eval|send}\n";
  882. _die "Incorrect syntax";
  883. }
  884. &log_close()
  885.