Mercurial > laserkard

annotate Laserkard.pm @ 51:95fa4bcc5d67 laserkard

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[svn r52] implemented SVG backend
author rlm
date Wed, 03 Feb 2010 03:14:09 -0500
parents
children 8324f195ef36
rev   line source
rlm@51 1 package Laserkard;
rlm@51 2
rlm@51 3 use List::Util qw(first max maxstr min minstr reduce shuffle sum);
rlm@51 4 use Storable;
rlm@51 5 use CGI::Ajax;
rlm@51 6 use CGI;
rlm@51 7 use JSON;
rlm@51 8 use Laserkard;
rlm@51 9 use base 'Exporter';
rlm@51 10
rlm@51 11 our @EXPORT =
rlm@51 12 qw(
rlm@51 13 material
rlm@51 14 template
rlm@51 15 inputbox
rlm@51 16 display
rlm@51 17 change_rules
rlm@51 18 vanish
rlm@51 19 updateForm
rlm@51 20 cardType
rlm@51 21 );
rlm@51 22
rlm@51 23
rlm@51 24
rlm@51 25
rlm@51 26
rlm@51 27 sub cardType
rlm@51 28 {
rlm@51 29
rlm@51 30 return $_[0];
rlm@51 31
rlm@51 32 }
rlm@51 33
rlm@51 34
rlm@51 35
rlm@51 36 sub updateForm
rlm@51 37
rlm@51 38 {
rlm@51 39
rlm@51 40
rlm@51 41 $key = shift;
rlm@51 42 $value = shift;
rlm@51 43 $hashString = shift;
rlm@51 44
rlm@51 45 $perl_hash = decode_json $hashString;
rlm@51 46
rlm@51 47 %fieldHash = %$perl_hash;
rlm@51 48
rlm@51 49
rlm@51 50 $fieldHash{$key} = $value;
rlm@51 51 $ref = \%fieldHash;
rlm@51 52
rlm@51 53 $utf8_encoded_json_text = encode_json $ref ;
rlm@51 54 return $utf8_encoded_json_text;
rlm@51 55
rlm@51 56 }
rlm@51 57
rlm@51 58
rlm@51 59
rlm@51 60
rlm@51 61 sub material{
rlm@51 62
rlm@51 63 $newvar = shift;
rlm@51 64
rlm@51 65 my $t = $newvar;
rlm@51 66
rlm@51 67 $newvar =~ m/([^_]*)_/;
rlm@51 68 $newvar = $1;
rlm@51 69
rlm@51 70 #return (($t =~ m/_acrylic_green/) ? 'CHECKED' : 'notchecked');
rlm@51 71
rlm@51 72 #$y = "$t<br>".(($t =~ m/_acrylic_green/) ? 'CHECKED' : 'notchecked')."
rlm@51 73
rlm@51 74 {
rlm@51 75 local( $/, *FH ) ;
rlm@51 76 open( FH, "<./buy_pieces/materials2.html" ) or die "sudden flaming death\n";
rlm@51 77 $y = <FH>;
rlm@51 78 }
rlm@51 79
rlm@51 80 @symbols = qw(PERL::ACRYLIC_CLEAR PERL::ACRYLIC_BLUE PERL::ACRYLIC_GREEN PERL::ALUMINUM_RED PERL::ALUMINUM_BLUE PERL::ALUMINUM_GREEN PERL::ALUMINUM_BLACK);
rlm@51 81
rlm@51 82 for (@symbols)
rlm@51 83 {
rlm@51 84 $c = $_;
rlm@51 85 $c =~ s/PERL:://;
rlm@51 86 $c =~ tr/[A-Z]/[a-z]/;
rlm@51 87 $c =~ s/^/_/;
rlm@51 88
rlm@51 89 $b = '"'.$newvar.$c.'"'.(($t =~ m/$c/) ? ' CHECKED ' : '');
rlm@51 90 $y =~ s/$_/$b/;
rlm@51 91 }
rlm@51 92
rlm@51 93
rlm@51 94 $first = shift;
rlm@51 95 if ($first){ $y =~ s/display[^;]*;//g; }
rlm@51 96
rlm@51 97
rlm@51 98
rlm@51 99 return $y;
rlm@51 100
rlm@51 101
rlm@51 102 }
rlm@51 103
rlm@51 104
rlm@51 105
rlm@51 106 sub template
rlm@51 107 {
rlm@51 108
rlm@51 109 $all = shift;
rlm@51 110 $all =~ m/([^_]*)_(.*)/;
rlm@51 111
rlm@51 112 $materialcolor = $2;
rlm@51 113 $style = $1;
rlm@51 114 #here is where we handle important drawing commands relating to the cards.
rlm@51 115
rlm@51 116
rlm@51 117
rlm@51 118 $r = <<HERE;
rlm@51 119 <div id = "i_templates"><div class = 'ttyl'> <titletron>Select Style.</titletron></div>
rlm@51 120 <div id = 'stupid'>
rlm@51 121
rlm@51 122
rlm@51 123 <input TYPE="image" src = "./images/templates/big_$materialcolor.jpg"
rlm@51 124 onmouseover="pokedex('big_$materialcolor');"
rlm@51 125 onmouseout = "pokedex(document.getElementById('currentSpec').innerHTML);"
rlm@51 126
rlm@51 127
rlm@51 128
rlm@51 129 onclick=
rlm@51 130 "display(['template2'], ['display']);
rlm@51 131 inputbox(['template2', 'formValues'], ['inputbox']);
rlm@51 132 material(['template2'], ['materials']);
rlm@51 133 cardType(['template2'], ['currentSpec']);
rlm@51 134 redraw('bold');"
rlm@51 135 ID="template2" NAME="template2" VALUE="big_$materialcolor">
rlm@51 136 <br>
rlm@51 137
rlm@51 138
rlm@51 139
rlm@51 140 <input TYPE="image" src = "./images/templates/basic_$materialcolor.jpg"
rlm@51 141 onmouseover="pokedex('basic_$materialcolor');"
rlm@51 142 onmouseout = "pokedex(document.getElementById('currentSpec').innerHTML);"
rlm@51 143 onclick=
rlm@51 144 "display(['template3'], ['display']);
rlm@51 145 inputbox(['template3', 'formValues'], ['inputbox']);
rlm@51 146 material(['template3'], ['materials']);
rlm@51 147 cardType(['template3'], ['currentSpec']);
rlm@51 148 redraw('arrow');"
rlm@51 149 ID="template3" NAME="template3" VALUE="basic_$materialcolor" ><br>
rlm@51 150
rlm@51 151
rlm@51 152
rlm@51 153 <input TYPE="image" src = "./images/templates/classic_$materialcolor.jpg"
rlm@51 154 onmouseover="pokedex('classic_$materialcolor');"
rlm@51 155 onmouseout = "pokedex(document.getElementById('currentSpec').innerHTML);"
rlm@51 156 onclick=
rlm@51 157 "display(['template1'], ['display']);
rlm@51 158 inputbox(['template1', 'formValues'], ['inputbox']);
rlm@51 159 material(['template1'], ['materials']);
rlm@51 160 cardType(['template1'], ['currentSpec']);
rlm@51 161 redraw('classic');"
rlm@51 162 ID="template1" NAME="template1" VALUE="classic_$materialcolor" ><br>
rlm@51 163
rlm@51 164
rlm@51 165
rlm@51 166 <input TYPE="image" src = "./images/templates/lines_$materialcolor.jpg"
rlm@51 167 onmouseover="pokedex('lines_$materialcolor');"
rlm@51 168 onmouseout = "pokedex(document.getElementById('currentSpec').innerHTML);"
rlm@51 169 onclick=
rlm@51 170 "display(['template4'], ['display']);
rlm@51 171 inputbox(['template4', 'formValues'], ['inputbox']);
rlm@51 172 material(['template4'], ['materials']);
rlm@51 173 cardType(['template4'], ['currentSpec']);
rlm@51 174 redraw('direct');"
rlm@51 175 ID="template4" NAME="template4" VALUE="lines_$materialcolor" >
rlm@51 176
rlm@51 177 </div>
rlm@51 178 </div>
rlm@51 179
rlm@51 180 HERE
rlm@51 181
rlm@51 182
rlm@51 183 %shankHash =
rlm@51 184 (
rlm@51 185
rlm@51 186 big => template2,
rlm@51 187 basic => template3,
rlm@51 188 classic => template1,
rlm@51 189 lines => template4
rlm@51 190 );
rlm@51 191
rlm@51 192 $target = $shankHash{$style};
rlm@51 193
rlm@51 194
rlm@51 195
rlm@51 196
rlm@51 197 #$r =~ s/inputbox\(\['$target'\], \['inputbox'\]\)\;//;
rlm@51 198
rlm@51 199
rlm@51 200
rlm@51 201
rlm@51 202
rlm@51 203 return $r;
rlm@51 204 }
rlm@51 205
rlm@51 206
rlm@51 207
rlm@51 208
rlm@51 209 sub inputbox
rlm@51 210 {
rlm@51 211
rlm@51 212 #grab the type of template we'll be using <<<<
rlm@51 213 $type = shift;
rlm@51 214
rlm@51 215 $hashString = shift;
rlm@51 216 #return $hashString;
rlm@51 217
rlm@51 218 $perl_hash = decode_json $hashString;
rlm@51 219
rlm@51 220 %fieldHash = %$perl_hash;
rlm@51 221
rlm@51 222
rlm@51 223 # we have to care about both the type of template and the material and the color. these are stored in $type>>>>
rlm@51 224
rlm@51 225 #Then, update with a special custon paypal form, taken from the paypal folder and specially designed for that particular template.
rlm@51 226 #will probaly eventually create a script to automate the generation of these files.
rlm@51 227
rlm@51 228
rlm@51 229 #take care of everythign but acrylic clear type
rlm@51 230
rlm@51 231 {
rlm@51 232 local( $/, *FH ) ;
rlm@51 233 open( FH, "<./paypal/$type.paylist" ) or die "sudden flaming death\n";
rlm@51 234 $z = <FH>;
rlm@51 235 }
rlm@51 236
rlm@51 237
rlm@51 238 #every type has it's own associated paylist file the contains the things we need
rlm@51 239
rlm@51 240 $z = <<HERE . $z;
rlm@51 241 <div id = "whatever" onmouseover = "pokedex(document.getElementById('currentSpec').innerHTML);">
rlm@51 242 HERE
rlm@51 243
rlm@51 244
rlm@51 245
rlm@51 246
rlm@51 247 $z = $z.'</div>';
rlm@51 248
rlm@51 249
rlm@51 250 foreach my $key ( keys %fieldHash )
rlm@51 251 {
rlm@51 252
rlm@51 253 my $replace = $fieldHash{$key};
rlm@51 254
rlm@51 255 #id="Name" value = "PERL::NAME"
rlm@51 256
rlm@51 257
rlm@51 258 $z =~ s/id="$key"/id="$key" value = "$replace"/g;
rlm@51 259
rlm@51 260
rlm@51 261 }
rlm@51 262
rlm@51 263
rlm@51 264 return $z;
rlm@51 265
rlm@51 266
rlm@51 267
rlm@51 268
rlm@51 269
rlm@51 270 }
rlm@51 271
rlm@51 272
rlm@51 273
rlm@51 274
rlm@51 275 sub display
rlm@51 276 {
rlm@51 277 $all = shift;
rlm@51 278
rlm@51 279
rlm@51 280 #~
rlm@51 281 #~ $t = <<HERE;
rlm@51 282 #~ <image src = "./images/display/PERL::PIC.jpg" onmouseover="pokedex(['args__PERL::PIC'],['pokedex']);">
rlm@51 283 #~
rlm@51 284 #~ <div id = overlay>
rlm@51 285 #~
rlm@51 286 #~
rlm@51 287 #~ </div>
rlm@51 288 #~
rlm@51 289 #~ HERE
rlm@51 290 #~
rlm@51 291 #~
rlm@51 292 #~
rlm@51 293 #~ $t =~ s/PERL::PIC/$all/g;
rlm@51 294
rlm@51 295 $t = <<HERE;
rlm@51 296 <image src = "./images/display/blank.jpg"
rlm@51 297 onmouseover = "pokedex(document.getElementById('currentSpec').innerHTML);"
rlm@51 298 >
rlm@51 299
rlm@51 300 <div id = overlay>
rlm@51 301
rlm@51 302
rlm@51 303 </div>
rlm@51 304
rlm@51 305 HERE
rlm@51 306
rlm@51 307 return $t;
rlm@51 308
rlm@51 309 }
rlm@51 310
rlm@51 311
rlm@51 312 sub genBuy
rlm@51 313
rlm@51 314 {
rlm@51 315 return gen("buy.html");
rlm@51 316
rlm@51 317 }
rlm@51 318
rlm@51 319
rlm@51 320 sub genEcho
rlm@51 321 {
rlm@51 322
rlm@51 323 return gen("echo.html");
rlm@51 324
rlm@51 325 }
rlm@51 326
rlm@51 327
rlm@51 328 sub gen
rlm@51 329 {
rlm@51 330
rlm@51 331 my $target = shift;
rlm@51 332
rlm@51 333 {
rlm@51 334 local( $/, *FH ) ;
rlm@51 335 open( FH, "<./$target" ) or die "sudden flaming death\n";
rlm@51 336 $a = <FH>;
rlm@51 337 }
rlm@51 338
rlm@51 339 {
rlm@51 340 local( $/, *FH ) ;
rlm@51 341 open( FH, "<./top_menu.include" ) or die "sudden flaming death\n";
rlm@51 342 $b = <FH>;
rlm@51 343 }
rlm@51 344
rlm@51 345 {
rlm@51 346 local( $/, *FH ) ;
rlm@51 347 open( FH, "<./cardDefinitions.JSON" ) or die "sudden flaming death\n";
rlm@51 348 $c = <FH>;
rlm@51 349 }
rlm@51 350
rlm@51 351 $a =~s/PERL::DEFS/$c/;
rlm@51 352
rlm@51 353
rlm@51 354
rlm@51 355 $a =~ s/PERL-REPLACE::TOP_MENU/$b/; #equivalent to <?php include("top_menu.html"); ?>, but in perl and with more memory problems :)
rlm@51 356 $b = &material("void_acrylic_clear",1);
rlm@51 357 $a =~ s/PERL-REPLACE::MATERIALS/$b/; #let's do it again!!! :)
rlm@51 358
rlm@51 359
rlm@51 360
rlm@51 361 $b = "big_acrylic_clear";
rlm@51 362 $a =~ s/PERL::INITIALCARD/$b/;
rlm@51 363 $b = &template("big_acrylic_clear");
rlm@51 364 $a =~ s/PERL-REPLACE::TEMPLATES/$b/;
rlm@51 365
rlm@51 366 $b = &display("big_acrylic_clear");
rlm@51 367 $a =~ s/PERL-REPLACE::DISPLAY/$b/;
rlm@51 368
rlm@51 369 $initials = <<HERE ;
rlm@51 370 {
rlm@51 371 "Name":"James Bond",
rlm@51 372 "Email":"jbond\@mi6.co.uk",
rlm@51 373 "Phone": "123.456.7890",
rlm@51 374 "Company": "MI6",
rlm@51 375 "Website" : "http://jamesbond.com",
rlm@51 376 "Occupation" : "Secret Agent"
rlm@51 377 }
rlm@51 378
rlm@51 379 HERE
rlm@51 380
rlm@51 381
rlm@51 382
rlm@51 383 $b = &inputbox("big_acrylic_clear", $initials);
rlm@51 384 $a =~ s/PERL-REPLACE::INPUTBOX/$b/;
rlm@51 385
rlm@51 386 $b = &pokedex('big');
rlm@51 387 $a =~ s/PERL-REPLACE::POKEDEX/$b/;
rlm@51 388
rlm@51 389
rlm@51 390
rlm@51 391 #$b = &updateForm('fuck','12', '{}');
rlm@51 392 $a =~ s/PERL::INITIALVALUES/$initials/;
rlm@51 393
rlm@51 394
rlm@51 395
rlm@51 396 return $a
rlm@51 397
rlm@51 398
rlm@51 399 }
rlm@51 400
rlm@51 401
rlm@51 402
rlm@51 403 sub pokedex
rlm@51 404 {
rlm@51 405
rlm@51 406
rlm@51 407 $classic = <<HERE;
rlm@51 408 <h1>The Classic LaserKard.</h1>
rlm@51 409 Balanced and Complete. The original LaserKard. For those that wish to leave no stone unturned. It's all there.
rlm@51 410 HERE
rlm@51 411
rlm@51 412 $bold = <<HERE;
rlm@51 413 <h1>The Bold Kard.</h1>
rlm@51 414 Austere and Iconic. For those that wish to leave an impression with the power of their name accompanied only by their main method of contact. Bold, period.
rlm@51 415 HERE
rlm@51 416
rlm@51 417 $arrow = <<HERE;
rlm@51 418 <h1>The Arrow Kard.</h1>
rlm@51 419 Precise and Straightforward. For those that seek to make a statement while being clear and concise. Straight as an arrow.
rlm@51 420 HERE
rlm@51 421
rlm@51 422 $direct = <<HERE;
rlm@51 423 <h1>The Direct Kard.</h1>
rlm@51 424 Thorough and Distinct. For those that aim to demonstrate their professionalism with style. Push the envelope. Be Direct.
rlm@51 425 HERE
rlm@51 426
rlm@51 427
rlm@51 428
rlm@51 429 my %megahash =
rlm@51 430 (
rlm@51 431
rlm@51 432 'big' => $bold,
rlm@51 433
rlm@51 434 'basic' => $arrow,
rlm@51 435
rlm@51 436 'lines' => $direct,
rlm@51 437
rlm@51 438 'classic' => $classic,
rlm@51 439
rlm@51 440 'big_acrylic_clear' => $bold,
rlm@51 441
rlm@51 442 'classic_acrylic_clear' => $classic,
rlm@51 443
rlm@51 444 'basic_acrylic_clear' => $arrow,
rlm@51 445
rlm@51 446 'lines_acrylic_clear' => $direct
rlm@51 447 );
rlm@51 448
rlm@51 449
rlm@51 450
rlm@51 451 my $key = shift;
rlm@51 452
rlm@51 453
rlm@51 454 if (!$megahash{$key}){return $key;}
rlm@51 455
rlm@51 456 return $megahash{$key};
rlm@51 457
rlm@51 458
rlm@51 459
rlm@51 460
rlm@51 461 }
rlm@51 462
rlm@51 463
rlm@51 464
rlm@51 465
rlm@51 466
rlm@51 467
rlm@51 468
rlm@51 469
rlm@51 470 # this here function makes the paypal button go away so people know it's working!
rlm@51 471 sub vanish
rlm@51 472 {
rlm@51 473 return "";
rlm@51 474
rlm@51 475
rlm@51 476 }
rlm@51 477
rlm@51 478 1;
rlm@51 479
rlm@51 480