Mercurial > laserkard

annotate Laserkard.pm @ 106:5b0753c6f34d laserkard tip

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