cgi/0040755000076400010020000000000007477023140010130 5ustar alexcvscgi/fileman.cgi0100755000076400010020000000730607470320545012237 0ustar alexcvs#!/usr/bin/perl # ================================================================== # File manager - enhanced web based file management system # # Website : http://gossamer-threads.com/ # Support : http://gossamer-threads.com/scripts/support/ # Revision : $Id: fileman.cgi,v 1.7 2002/05/14 23:44:37 bao Exp $ # # Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved. # Redistribution in part or in whole strictly prohibited. Please # see LICENSE file for full details. # ================================================================== use lib '../private/lib'; use strict; use GT::Base qw/:all/; use GT::CGI; use GT::FileMan; $| = 1; local $SIG{__DIE__} = \>::FileMan::fatal; main(); sub main () { #------------------------------------------------------------------- # Main process # my $fm = GT::FileMan->new( commands => { cmd_search => 1, cmd_replace => 1, cmd_command => 1, cmd_upload => 1, cmd_editor => 1, cmd_passwd => 1, cmd_makedir => 1, cmd_preferences => 1, cmd_edit => 1, cmd_download => 1, cmd_copy => 1, cmd_delete => 1, cmd_move => 1, cmd_chmod => 1, cmd_tail => 1, cmd_perl => 1, cmd_diff => 1, cmd_tar => 1, cmd_admin => 1, } ); # Set our tmp directory. $ENV{GT_TMPDIR} = $fm->{cfg}->{'root_path'} . '/private/tmp'; # Check to see if we need to authenticate. if ($fm->{cfg}->{username} and $fm->{cfg}->{password}) { my $username = $fm->{in}->cookie('username') || ''; my $encrypted = $fm->{in}->cookie('password') || ''; my $scheme = $fm->{in}->cookie('scheme') || 'fileman'; if ($fm->{cgi}->{login}) { $username = $fm->{cgi}->{username} || ''; $encrypted = crypt($fm->{cgi}->{password}, $username); } if (!$username or ($username ne $fm->{cfg}->{username}) or ($encrypted ne crypt($fm->{cfg}->{password}, $username))) { my $msg = $fm->{cgi}->{login} ? $GT::FileMan::Commands::LANGUAGE{ERR_LOGIN} : ''; return $fm->page('login_form.html',{ msg => $msg , username => $fm->{cfg}->{username}, scheme => $scheme, html_url => $fm->{cfg}->{html_root_url} }); } # Logged in ok, save username, password into cookie elsif ($fm->{cgi}->{login}) { print $fm->{in}->header (-cookie => [ $fm->{in}->cookie ( -name => 'username', -value => $username, -expires => ''), $fm->{in}->cookie ( -name => 'password', -value => $encrypted, -expires => ''), ]); } } $fm->process(); } images/0040755000076400010020000000000007477023142010635 5ustar alexcvsimages/icons/0040755000076400010020000000000007477023140011746 5ustar alexcvsimages/icons/1pixel.gif0100755000076400010020000000005307401552675013644 0ustar alexcvsGIF89a!,D;images/icons/back.gif0100755000076400010020000000030107432602217013326 0ustar alexcvsGIF89a2!,2nI8ͻ`(ahک`/0Й pgpŎ4eP-MKI6'(5yTO|ߓ&X6/WgcX{}$;images/icons/binary.gif0100755000076400010020000000036607401552675013735 0ustar alexcvsGIF89a̙333!NThis art is in the public domain. Kevin Hughes, kevinh@eit.com, September 1995!,iH0@$Y ]!q^ k굮jAvQh)n%Ӗ*ԂZU)􄧴9!_8s; JI;CS ;images/icons/close.gif0100755000076400010020000000022107401552675013544 0ustar alexcvsGIF89a@@@Ȁ,;,(ACiAXP`%vZpZ4rШB$!Optimized by Ulead SmartSaver!;images/icons/compressed.gif0100755000076400010020000000201607401552675014607 0ustar alexcvsGIF89af3̙f3f3ffffff3f3333f333f3f3̙f3̙̙̙̙f̙3̙ffffff3f3333f333f3̙f3̙̙f3̙f3ff̙ffff3f33̙33f333̙f3ffffff3ffff̙fff3fffffff3ffffffffffff3fff3f3f3f3ff33f3ffffff3f3333f333333̙3f3333333f3333f3f3f3ff3f33f33333333f333333333f333f3̙f3f3ffffff3f3333f333f3wUD"wUD"wUD"ݻwwwUUUDDD"""!NThis art is in the public domain. Kevin Hughes, kevinh@eit.com, September 1995!$,I$`dCV #lСĄ+Z(0cC'NJI\GVbZi/aƤ@75ICϟF983O@lh%QV9L4jϩ^: 3؞K*gZ-mv}(ԧҔ%+2K$€;images/icons/doc.gif0100644000076400010020000000024307432602217013175 0ustar alexcvsGIF89a!,P@$%I4@!ڎa,V+t1V>gj2ϕfy[fڰ*mװ<;images/icons/fileman_logo.gif0100644000076400010020000000303007401552675015070 0ustar alexcvsGIF89aZ( ]eYۦEGD.2-pf򇞀ҔσˣՕA?xt|{ed!,Z( "dh+ImI|/ !H,:"t@PB*f9?zn; |>L*&)WZZ]^_defgnmtJyQR] diptuwFKz{}SSYnBwyɴU h« ߘsDM |[bՋ؎qt(,@@! `]p+\r;C]8`7@8 XpBh:b $``B  Zy50-UoxՀ| (A .peIۀ8ۑ*5I6&7iݷ58 I' p:P\}VpiLC*f^9LWAڀP9 @?."ttOFRxiT'L(mnO\Ё À(7~H l@{_APx X0ޞVH A!F!7T0PŅ 7\: Dk\8eI#)zXR@& C=EalCG LarpçzBĩq ;!Ql$?MIPRE^8"WK>"8: 4TIBcNuG%٨IމI d X$R$OD? Gq($)O(l$+H JP%0Eb3ȤpL8ә!;images/icons/folder.gif0100644000076400010020000000022307432602217013701 0ustar alexcvsGIF89a cΜ!, @@AH)MFiU5ulx_mlG紝0Y7)ȃsmJs"z;images/icons/ie.gif0100644000076400010020000000162307432602217013030 0ustar alexcvsGIF89a c11c1c1ccsssccΜc1c1cc!, pH0A&0@C8Qب1  p  Hp0H@'?"tP AE@p @4Q LYfՅhů`;images/icons/image2.gif0100755000076400010020000000046507401552675013615 0ustar alexcvsGIF89a33̙ffff33333f!NThis art is in the public domain. Kevin Hughes, kevinh@eit.com, September 1995!,IXGvm^IYv*:A,6k-Ő6KX5T%8kV b4j i e,|y7W/+fz%~w %PO@IR;images/icons/p.gif0100755000076400010020000000035507401552675012706 0ustar alexcvsGIF89a333!NThis art is in the public domain. Kevin Hughes, kevinh@eit.com, September 1995!,`80 @#i;GUE%M+P@:aQ*!-DYV(szd;/9hFu,Wü^x ;images/icons/parent.gif0100755000076400010020000000033007401552675013731 0ustar alexcvsGIF89afff333!NThis art is in the public domain. Kevin Hughes, kevinh@eit.com, September 1995!,K#j3Si7Nvt7*EnXm/5FPxƤl(N ڌ:@VUϋ;images/icons/pdf.gif0100644000076400010020000000024107401552675013207 0ustar alexcvsGIF89a1Ƅ,K*A+-pD(`8NƵ`%@\:JP,4Ԇ‹j0]o \!Optimized by Ulead SmartSaver!;images/icons/quill.gif0100755000076400010020000000041307401552675013570 0ustar alexcvsGIF89afff3333!NThis art is in the public domain. Kevin Hughes, kevinh@eit.com, September 1995!,~h0@&i;WGxp]BqHR/!:,Cb V%H@@d)6<1EY!~˺A=v,ipgZp[ys" ;images/icons/script.gif0100755000076400010020000000036207401552675013751 0ustar alexcvsGIF89a333!NThis art is in the public domain. Kevin Hughes, kevinh@eit.com, September 1995!,e80 @#i;U"U0MTq;`( T(9LR{lz5 ^j,Fp5 P;~3 C7sc ;images/icons/sound1.gif0100644000076400010020000000037007440774571013656 0ustar alexcvsGIF89a33̙f333!NThis art is in the public domain. Kevin Hughes, kevinh@eit.com, September 1995!,k(06BaUq h~ rwi4[AHkwṄ O48fqz*** oԜCT:3M*6$>}J{v,{  ;images/icons/text.gif0100644000076400010020000000017407401552675013427 0ustar alexcvsGIF89a , 2rh(bzKg5pg8!2lt}=jDlG!Optimized by Ulead SmartSaver!;images/icons/unknown.gif0100755000076400010020000000036507401552675014147 0ustar alexcvsGIF89a333!NThis art is in the public domain. Kevin Hughes, kevinh@eit.com, September 1995!,h80 @#i;a"Qyʵ.J 70֧#$ @*,K|'"-K<%$`[˓j%ޕx,6!R̽r>0Id_7^WvJ𮍳o_OxO2->+_-6|?cGW];n+Ҽ+mo&Y1̭[zj?F®cko=#ц-炗siϞ ]#{#᝞/G+ov{ҿ7ꜜǃ`}rc1Zo/S1½ zv-rsj~w/['\vv𧅱dҸ>/ӵ{|-Xҿslۗ1S>{LB![þw~ѶhѼ='Ojt]f>Jss~]O;KӶmymx-NۏiW?EC|QNB>VG=W_R"-q_,|%~kWcz5>i{ӵ}IC|Oy^V$_P|$ǖcLw4|G}gAjþe򿆾hG#=;^%OsC0yl>Hsr֝иoi6|r_/4i~2p|ֿi8tpb8F4>iv|lb/^nE^n\j&{[gOmcφ(y޾i+z(1l^oy{?}p{h}G埴zwsFh_G3 "ӽ~p>:/yn\7 ֻ ־M_/3gZ˳2_ p oat_Þ!BOֻ "]ux/C Լݟ6kp>˗C -})n}4WTEVV(/5~=ywW;HñgofXG^<J?^Ǖ߭x |;iWN^ >ǧz_Q"t>o,sN{8;{b8*r6M+kÿ^nwxw/7_(|2Jᝮ |zW/R30pïy0>>oC/嵮FAҿ@2PƘzP~}~Q_ah$GW S<ڼ+{p+e?W&qK?Š_ i5=b#7 ŝpkҼ+{o5;k\ Ÿ-Rv^KL⼫ºͣw^]wnߟ~ù ֺ?O6=cV9zHw6m̟z|SWkp98?2#G.r} >+~Zǥ|[c^Yޕp5?gXZg`+~+;""ZWVzW]rh|i?X}iQޕ?>}+寅z/~1_[C3;}O$wiҊoNtQ_b?#*>it1oכ@水G_jຸUvxT>M)R3&?7W)7qڽ헁CQd]B/zv>7sڿJ7fwU-C>1~O1y__O#|_;~Q٤?=Dz.ߒ+<23V>31~Ǚw??O ywW+]+sdq9ῆnҽ?⳩6j<)Wxv҇~_.K?1b?cjᯃ/^>yA3׊4DS?~iļCy>rY#;W 4/;}+ njc{74L:Wc6e>MhlҊri3*.?pyYǥ{ý# ,jᜠy|W j~]ugkoNl_j3W _eC 31P?Y?j.)g+c}7{5`n_qZP/`Hܳ_ zW<b+ҳ<9{5wk.(^?x<+/o^M;+%ٳHܚ2̣^>[-1E.so+*;ͳ "7 ydW? Ǘvy~د|s.<J8߫?28ߘ# u{<}+)ϥ{ëy|W⟫3ߘO6^-@c~_cg^ @W?}y |>f;yB;y&B^k ?cpfܧxjpvסxe82z?_%kfXYd-zRh(Y;иox½QE|oU/c/Ip s^9C?1Pr=6|ޕ?w=Y$mq=?w ^;+4NבB+ ϝ|5gk\h6+:.?images/fileman.css0100755000076400010020000000162207432602202012752 0ustar alexcvsa:active { font-weight: normal; color: #0000FF; text-decoration: none} a:hover { color: #CC0000; text-decoration: none} .header_format { background-color: #000099; font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; font-weight: bold; color: #FFFFFF} .text_format { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt ; color: #OOOOOO} .button { background-color:#FFFFFF; color: black; font-family: Arial, Verdana, Helvetica, sans-serif; font-size: 12px; } .submit { background-color:#D6D6D6; font-family: Arial,Verdana,Helvetica, sans-serif; font-size:12px; color:black} .highlight { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; color:#CC0000; background-color: #E6E6FF} .background { background-color: #E9E9E9; color:#000066 } .bg_main { background-color: #FFFFFF; } .bg_main2 { background-color: #D8D8D8; } .bg_window { background-color: #D6D6D6; }images/fileman.js0100644000076400010020000003322007447720607012612 0ustar alexcvsvar ie = (document.all)? true:false; function CheckAll(cb) { if (wasDownload()) return; var fmobj = window.top.mainfrm.document.frm_main ; var count = 0; var total_space = 0; var num_selected = 0; if (typeof(fmobj.dparent) != 'undefined') count = 1; for (var i=0;i 3) { var mod = number.length%3; var output = (mod > 0 ? (number.substring(0,mod)) : ''); for (i=0 ; i < Math.floor(number.length/3) ; i++) { if ((mod ==0) && (i ==0)) output+= number.substring(mod+3*i,mod+3*i+3); else output+= ',' + number.substring(mod+3*i,mod+3*i+3); } return (output); } else return number; } function print_filesize(size) { var formatted_size = 0; if (size > 0) formatted_size = parseInt(size / 1000); else return 0; if (formatted_size == 0) return size + ' bytes'; else { return outputComma(formatted_size) + ' kb'; } } function hL(E){ if (ie) { while (E.tagName!="TR") {E=E.parentElement;} } else { while (E.tagName!="TR") {E=E.parentNode;} } E.className = "highlight"; } function dL(E){ if (ie) { while (E.tagName!="TR") {E=E.parentElement;} } else { while (E.tagName!="TR") {E=E.parentNode;} } fillColor(); } function fillColor () { var count = 0; var tables = window.top.mainfrm.document.getElementsByTagName('TABLE') var mytable; for (var i=0; i1) {break} } if (! _checked) { if (multi) {return 'Please select the files or directories.';} else {return 'Please select a file.';} } if (count > 1 && multi == false) { return 'Can not execute the command because the selected file more than one.' } return; } function init_chmod() { var frm = top.bottomfrm.document.frm_footer; var u_mod=0,g_mod=0,w_mod =0,a_mod=0; if (frm.ar.checked) {a_mod = 4;} if (frm.ur.checked) {u_mod = 4;} if (frm.gr.checked) {g_mod = 4;} if (frm.wr.checked) {w_mod = 4;} if (frm.aw.checked) {a_mod += 2;} if (frm.uw.checked) {u_mod += 2;} if (frm.gw.checked) {g_mod += 2;} if (frm.ww.checked) {w_mod += 2;} if (frm.ax.checked) {a_mod++;} if (frm.ux.checked) {u_mod++;} if (frm.gx.checked) {g_mod++;} if (frm.wx.checked) {w_mod++;} frm.txt_input.value = a_mod + '' + u_mod + '' + g_mod + '' + w_mod ; } function js_show_chmod(name,perm) { if (top.wasDownload()) return; var fmobj = window.top.mainfrm.document.frm_main ; for (var i=0;i'; js_cmd_chmod(); if (perm.length == 16) { if (perm.substr(0,1) == 'r') {window.top.bottomfrm.document.frm_footer.ar.checked =true} if (perm.substr(1,1) == 'w') {window.top.bottomfrm.document.frm_footer.aw.checked =true} if (perm.substr(2,1) == 'x') {window.top.bottomfrm.document.frm_footer.ax.checked =true} if (perm.substr(4,1) == 'r') {window.top.bottomfrm.document.frm_footer.ur.checked =true} if (perm.substr(5,1) == 'w') {window.top.bottomfrm.document.frm_footer.uw.checked =true} if (perm.substr(6,1) == 'x') {window.top.bottomfrm.document.frm_footer.ux.checked =true} if (perm.substr(8,1) == 'r') {window.top.bottomfrm.document.frm_footer.gr.checked =true} if (perm.substr(9,1) == 'w') {window.top.bottomfrm.document.frm_footer.gw.checked =true} if (perm.substr(10,1) == 'x') {window.top.bottomfrm.document.frm_footer.gx.checked =true} if (perm.substr(12,1) == 'r') {window.top.bottomfrm.document.frm_footer.wr.checked =true} if (perm.substr(13,1) == 'w') {window.top.bottomfrm.document.frm_footer.ww.checked =true} if (perm.substr(14,1) == 'x') {window.top.bottomfrm.document.frm_footer.wx.checked =true} } else { if (perm.substr(0,1) == 'r') {window.top.bottomfrm.document.frm_footer.ur.checked =true} if (perm.substr(1,1) == 'w') {window.top.bottomfrm.document.frm_footer.uw.checked =true} if (perm.substr(2,1) == 'x') {window.top.bottomfrm.document.frm_footer.ux.checked =true} if (perm.substr(4,1) == 'r') {window.top.bottomfrm.document.frm_footer.gr.checked =true} if (perm.substr(5,1) == 'w') {window.top.bottomfrm.document.frm_footer.gw.checked =true} if (perm.substr(6,1) == 'x') {window.top.bottomfrm.document.frm_footer.gx.checked =true} if (perm.substr(8,1) == 'r') {window.top.bottomfrm.document.frm_footer.wr.checked =true} if (perm.substr(9,1) == 'w') {window.top.bottomfrm.document.frm_footer.ww.checked =true} if (perm.substr(10,1) == 'x') {window.top.bottomfrm.document.frm_footer.wx.checked =true} } init_chmod(); top.mainfrm.show_msg('0',1); } function check_command() { if (top.wasDownload()) return; if (typeof(window.top.mainfrm.frm_main) == 'unknown' || typeof(window.top.mainfrm.document.frm_main) == 'undefined') { alert("Please return to main screen and execute the command again"); return false } var msg var act = new Array(9); act[0] = 'cmd_copy'; act[1] = 'cmd_delete'; act[2] = 'cmd_move'; act[3] = 'cmd_chmod'; act[5] = 'cmd_perl'; act[6] = 'cmd_tar'; act[7] = 'cmd_download'; act[4] = 'cmd_tail'; act[8] = 'cmd_diff'; var cmd_do = window.top.bottomfrm.document.frm_footer.cmd_do.value for (ii=0; ii< 9; ii++) { if (act[ii] == cmd_do) { if (cmd_do == 'cmd_tail') { if (typeof(window.top.mainfrm.document.frm_main.type) == 'undefined') {msg = check_selected(false)} } else if (cmd_do == 'cmd_diff') { if (typeof(window.top.mainfrm.document.frm_main.type) == 'undefined') {msg = check_selected(false)} } else if (cmd_do == 'cmd_perl'){ if (typeof(window.top.mainfrm.document.frm_main.type) == 'undefined') {msg = check_selected(true)} } else {msg = check_selected(true)} if (msg){ alert(msg) return false; } break } } if (cmd_do != 'cmd_perl' && cmd_do != 'cmd_uncompress') {msg = top.bottomfrm.check_input();} if (msg){ alert(msg) return false; } if (cmd_do == 'cmd_tar' && typeof(window.top.bottomfrm.document.frm_footer.opt_gz) != 'undefined') { if ( window.top.bottomfrm.document.frm_footer.opt_gz.checked) window.top.mainfrm.document.frm_main.opt_gz.value = 1 } if (cmd_do == 'cmd_search' || cmd_do == 'cmd_replace') { window.top.mainfrm.document.frm_main.scope.value = 0 if (window.top.bottomfrm.document.frm_footer.scope.selectedIndex == 1) window.top.mainfrm.document.frm_main.scope.value = 1 if (window.top.bottomfrm.document.frm_footer.c_case.checked) window.top.mainfrm.document.frm_main.c_case.value = 1 if (window.top.bottomfrm.document.frm_footer.c_regex.checked) window.top.mainfrm.document.frm_main.c_regex.value = 1 if (cmd_do == 'cmd_search' && window.top.bottomfrm.document.frm_footer.c_content.checked) window.top.mainfrm.document.frm_main.c_content.value = 1 if (cmd_do == 'cmd_replace') { if (window.top.bottomfrm.document.frm_footer.c_word.checked) window.top.mainfrm.document.frm_main.c_word.value = 1 if (window.top.bottomfrm.document.frm_footer.c_bak.checked) window.top.mainfrm.document.frm_main.c_bak.value = 1 window.top.mainfrm.document.frm_main.txt_with.value = window.top.bottomfrm.document.frm_footer.txt_with.value; } } if (cmd_do == 'cmd_tail') { var objtime = window.top.bottomfrm.document.frm_footer.retime.options window.top.mainfrm.document.frm_main.retime.value = objtime[objtime.selectedIndex].value } window.top.mainfrm.document.frm_main.cmd_do.value = cmd_do; window.top.mainfrm.document.frm_main.txt_input.value = window.top.bottomfrm.document.frm_footer.txt_input.value; window.top.mainfrm.document.frm_main.submit(); if (cmd_do != 'cmd_tail') {window.top.bottomfrm.document.frm_footer.txt_input.value = '';} return false } function js_cmd_edit() { if (typeof(window.top.mainfrm.frm_main) == 'unknown' || typeof(window.top.mainfrm.document.frm_main) == 'undefined' || typeof(window.top.mainfrm.document.frm_main.main_screen) == 'undefined') { alert("Please return to main screen and execute the command again"); return } var msg = check_selected(false) if (msg) { alert(msg) return } window.top.mainfrm.document.frm_main.cmd_do.value = 'cmd_edit'; window.top.mainfrm.document.frm_main.submit(); } function js_cmd_delete() { if (top.wasDownload()) return; if (typeof(window.top.mainfrm.frm_main) == 'unknown' || typeof(window.top.mainfrm.document.frm_main) == 'undefined' || typeof(window.top.mainfrm.document.frm_main.main_screen) == 'undefined') { alert("Please return to main screen and execute the command again"); return } var msg; msg = check_selected(true); if (msg) { alert(msg); return } if (confirm('Do you really want to delete the selected files and directories?')) { window.top.mainfrm.document.frm_main.cmd_do.value = 'cmd_delete'; window.top.mainfrm.document.frm_main.submit(); } } function js_run_command () { if (top.wasDownload()) return; var msg; if (typeof(window.top.mainfrm.document.frm_main.type) == 'undefined') {msg = check_selected(false)} if (msg){ alert(msg) return false; } window.top.mainfrm.document.frm_main.cmd_do.value = window.top.bottomfrm.document.frm_footer.cmd_do.value; window.top.mainfrm.document.frm_main.txt_input.value = window.top.bottomfrm.document.frm_footer.txt_input.value; window.top.mainfrm.document.frm_main.submit(); } function load_progress_bar (pxs,percent,msg) { if (ie) { var img = window.top.bottomfrm.document.images.progess; if (typeof(img) != 'undefined') { var wimg = img.width; img.width = Number(pxs); if (pxs == '-1' || img.width>500 ) { img.width = 496; window.top.bottomfrm.document.frm.percent.value = "100%" window.top.bottomfrm.document.frm.msg.value = "The selected files has been copied" } else { window.top.bottomfrm.document.frm.percent.value = percent + '%' window.top.bottomfrm.document.frm.msg.value = "Processing... "+msg } } } else { window.top.bottomfrm.document.frm.msg.value = msg } } function additem(objright,objleft,flag){ //-------------------------------- if (flag == 1) {// add all var src = eval(objleft); var rows = src.options.length for (ii=1; ii< rows ; ii++) { moveitem(eval(objleft),eval(objright),1); } } else moveitem(eval(objleft),eval(objright)); } function removeitem(objright,objleft,flag){ //------------------------------------ if (flag == 1) {// move all var src = eval(objright); var rows = src.options.length for (ii=1; ii< rows ; ii++) { moveitem(eval(objright),eval(objleft),1); } } else moveitem(eval(objright),eval(objleft)); } function moveitem (src,tar,index) { li_rows = tar.options.length if (index > 0) li_index = index else li_index = src.selectedIndex var objs = 0; if (li_index <= 0) { alert("Please select an item.") return } // get value & text from objright text = src.options[li_index].text value = src.options[li_index].value // add item into lbleft from lbright. if (li_rows==0) { tar.options[0] = new Option(text,value); } else { tar.options[li_rows] = new Option(text,value); tar.options[li_rows].selected = true } for (m=src.options.length-1;m>=0;m--) { if (src.options[m].value==value) src.options[m]=null } } images/gt.css0100755000076400010020000000164007432602202011751 0ustar alexcvsa:active { font-weight: normal; color: #0000FF; text-decoration: none} a:hover { color: #CC0000; text-decoration: none} .header_format { background-color: #256A19; font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; font-weight: bold; color: #FFFFFF} .text_format { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt ; color: #OOOOOO} .button { background-color:#D2EDB8; color: black; font-family: Arial, Verdana, Helvetica, sans-serif; font-size: 12px; } .submit { background-color:#d9e4f2; font-family: Arial,Verdana,Helvetica, sans-serif; font-size:12px; color:black} .highlight { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; color:#0033CC; background-color: #FFCECE} .background { background-color: #E6F5D7; color:#000000 } .bg_main { background-color: #FFFFFF; } .bg_main2 { background-color: #CDD6C0; } .bg_window { background-color: #d9e4f2; border: #d9e4f2}images/maple.css0100755000076400010020000000164007432602202012435 0ustar alexcvsa:active { font-weight: normal; color: #0000FF; text-decoration: none} a:hover { color: #CC0000; text-decoration: none} .header_format { background-color: #800000; font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; font-weight: bold; color: #FFFFFF} .text_format { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt ; color: #OOOOOO} .button { background-color:#F8F3E7; color: black; font-family: Arial, Verdana, Helvetica, sans-serif; font-size: 12px; } .submit { background-color:#F0E8CE; font-family: Arial,Verdana,Helvetica, sans-serif; font-size:12px; color:black} .highlight { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; color:#0033CC; background-color: #FFCECE} .background { background-color: #F0E8CE; color:#000066 } .bg_main { background-color: #F8F3E7; } .bg_main2 { background-color: #D8D8D8; } .bg_window { background-color: #F0E8CE; border: #E6D8AA}images/rainy.css0100755000076400010020000000164007432602202012461 0ustar alexcvsa:active { font-weight: normal; color: #0000FF; text-decoration: none} a:hover { color: #CC0000; text-decoration: none} .header_format { background-color: #4F657D; font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; font-weight: bold; color: #FFFFFF} .text_format { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt ; color: #OOOOOO} .button { background-color:#E3E9DC; color: black; font-family: Arial, Verdana, Helvetica, sans-serif; font-size: 12px; } .submit { background-color:#CFD8C2; font-family: Arial,Verdana,Helvetica, sans-serif; font-size:12px; color:black} .highlight { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; color:#000066; background-color: #FFCCCC} .background { background-color: #CFD8C2; color:#000000 } .bg_main { background-color: #E3E9DC; } .bg_main2 { background-color: #A5B5C7; } .bg_window { background-color: #CFD8C2; border: #CFD8C2}images/rose.css0100755000076400010020000000163507432602202012313 0ustar alexcvsa:active { font-weight: normal; color: #0000FF; text-decoration: none} a:hover { color: #CC0000; text-decoration: none} .header_format { background-color: #9F6070; font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; font-weight: bold; color: #FFFFFF} .text_format { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt ; color: #OOOOOO} .button { background-color:#EEE3E6; color: black; font-family: Arial, Verdana, Helvetica, sans-serif; font-size: 12px; } .submit { background-color:#DEC9CE; font-family: Arial,Verdana,Helvetica, sans-serif; font-size:12px; color:black} .highlight { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9pt; color:red; background-color: #CCCCFF} .background { background-color: #DEC9CE ; color:#000000 } .bg_main { background-color: #EEE3E6; } .bg_main2 { background-color: #CFAFB7; } .bg_window { background-color: #DEC9CE; border: #DEC9CE}images/schemes/0040755000076400010020000000000007477023140012262 5ustar alexcvsimages/schemes/fileman.jpg0100644000076400010020000006364507432602224014407 0ustar alexcvsJFIF,,CC" Y  !SU"1TXQRV #$7Av4BCWq235a%DruL !1"AQ#2RaSqBTUb3W$&4%Es ?]d@ʵ,4x&1yI69W!0J+B깅Tuot}?<㕳Ec ։Ҏh-cBZs M|;to$nG!%%}$-McTbGq^UN_&98]Y#H M>/VFtQuظӇgrѽZVbz&:*lA-v\빱wl)@>ȍ'.ЊA(mU)dmjԕ̶2 pSaHQ1:je2V1kl5ʋ]0g t`!F[GYTq4SVedPP4 f=}BIH HocVTXZN|' UɒkBk=D:ƙ̀" LJm9ehjh#, AX{,3k.R8kb\ $~&t8^d.#2RA8`4ΛJe\v#J֢J±lF?\S%东[؁i6kחC j+Ezb L(R"h#eZ]+I"UBK5[2 ^@Wܯ=be]aܬW_۸Z&Mg\4RɬʎSYU6k xbx!ڧ(},6JMqH2m-eu68ͽKJ1 o<'Ո8{[eȍuYZ [O-t" [Z*0:?gl'tx-WXڙmslDV`L UF!ڧ(},6(RSZ(d+։{$22"5T^(PVng_1g ƎQZAe.@dovEz"0|%%9EH|eY:BA6݉&<'K>~ ϣjl򸓚B \)iot)BhuJa+ ݴGs&UGi9Z5eĸ1YIӤJWh_,NfMl/avc`;w}&-#FgbKjeaF%(},6NJ<'K>~]naH=d4&. 4̷9^Õ^1b zqc*QcWgвerJYvƪmtXedB" ;(ఄeg/':6[\B Hr<+ .WB$5n{Xݎ%(},6NJ<'K>~ηx\jLn{xH+Z:YBw2):qӑ)9rM1 FbHDL{qcV#zH4О㟦00Feհ4E$r˻ QңIQL"Zݣr'lnIS:D.Ԝ9?7矗&]؅:\jVT&!QT*HzXls9B Ǔ|hG,b}^E>|A#Yu#F檵嵰I-9Xכ]H ϻ Q)q vn@y?,nQ?YmS͕tW|E:+S5왡-5cr$Y$o TjGMa05gBFlfF "<1̅G$bxWt\7I2GY%bbn˖8aI2902=`[$yp0yE, "y@o> YMY]k$=)&ƚqTq//Tv ^c4l[8MzK6"ɔT5lj#|.)#\(0+x;9XJ^EI[m8wG>n#eSa9A'҈Q|qpUK`Zq%f51{6K\pXK|WWcb9{ .;Z6GǏ _ʴ̓9[ڂ5+cd4c Z"өW&`g=z;h%{{Ju,3px9ed$W)KDBs@\EkI{a>ԝ֭pg`4l"Ht}E-bؾUOe1 :i#cƈWRq4nʆQFo~ɺw5?H+QU=%<&dDpzKN'c:C*A #b40פѸl; $noIgo9"U[Pz,L;ĬC]a+&d@Ɓ.)A =S^W.qGd1iniDNkiw2I'dy$d߷ J{UkV)l:Hz5 C*#4\k;enCϽ 6 S \P' $qj״GG꿓C_%}bCQ=fK=+)TpDv7\P21X0L8-؀f}gQh߸?c1w2 rٿԿοk0S?#5<} >$YE>bEZ;71w2 r]̿>??`!)"J->,oQqbeAK,TH ._}gQh؀fz]̿>>s/G--_g_5:HJGktjV}[&ƫ>3,lf Byb4eG©Fr9YgƟ*b+go{*W1BZPwdS9Ds+ീDf%[|pAmE֊SZH5M @s^$9RkUr"v[w&{s]/0mYRUFU2Sؤj򻗊q.U> )>3$B93L$;1Ƚ )(UWZ +K!$/Dq+"J-ciI'ܿ {!]/_Raaa#paTCw?{1w2 r˹F3:iU$8PeWY$rDFy*mzS*?ޞAhL⼢9l+"N+rTql Y 7X^Cb>uHqC !sjh0;@R,7p"D Vc+7%!PA U#"sKH L i.P?)|&c!lv/iJV;#6Z2VM(2 rh6ѐLiۙw.KcDԩ_[Jwzhm e!?LU RVY0fBhO@'K\6}gQh{ZתuSzg%[K=`\=h+d}nT Jھ't!!I j}9om^46~B*!LI24̋\ [PuӶû˘tQ .MԣjcU2Fх`P*tXR$)EAmxIĬߋw4JdkXqh^3h"!օMU@.s)R"&hxI3ڞ]Tw54l+t%Lɉ^F,$[ Ž#HHSXGhњ2HcǢe#k 53eW/+, \GHޭ,0]tN*|5S]TI $u:<:xy[ r[y>,c"J- T61 cn0CaYcHyWYI=c#Em$W1;{}N&6)-=fV+(+DEVWjMӿIrGc<{Zc}#b9f nO!/w;x jOeUċEd nNb_[ծ$-:htȒ^)SQB}-^nc6Y[.۾6wKVV*.9։!ĒйŎp0^#'[-´ws iVQwvìJQڕ[-M;srͯe]w";#"ܟH ؎:+LS6:9(9mǂmRKS>ʝB3&O^L*t;Z:`tf*DÃۏ*}gQhٰ k;/}pߧu*ǞM$Ȩ4w9cD22K]̿>\sDOgd;oIpmdVF=E&8"HPq:j2ɬzOTGf֊7i2bj("0qzQF:6v*jX9!mom˞:ނmԊ}̲Uu|\2I+ vsn];$IEYb<я `Ƒ@={ҝwV';w̱ʊ~U^G_yd!(cq۷Pza3\1w_5M).&Xt̒c1RX=2ABak_= e2E MR+uaWZ54AIAәY'%v?Q{m$;6qsoB-GQ09"m+gWZ]]jkb#A>9$,t>i 3%udK&hiya _ B9łL҈7;jqlTN(RMēE|e_T1 lZ #zM4ҝ7éEH|<RTMW \AY1H¬XLw#:;-dԬ<1QAѩaf1#HYeQ"86F&vaxΉ?e:'dzپb_ /1/|G0ZocU'RmNHN";dJ ?:'dzܲQjQU{DDdx|(868E-7:'dz-Kn~#6>Bkv}Yq ʁk%cVBiEz9^b_ /91WW@O̭cLd5M:lRD3r`V5O8{lMu=x⸖37nXRj X+p Vؕ#lT/lCSxa+읩Cv'c3Ʋ;( )-j W9(LyQE>RѴRfy(C6hNG{H^‘ɰBөՌ#kTK,}cԖ4(mY9NH {Vw憚$zvPe̍Ykͳ\.H&eR657yT .n;lt0\V5M'9 ])/ole01x2v\`r3+DĬNΒdIt%lEf)}L cbQu!Er)#Q*qBFAy%{ՕU,k]\,EV lm}v5%9 J uʞ 5,!Jl M.k!!e_ؾE%v܍xBoE☮b# 8Dp0QA=?j*&'H7lT\XcbDXTgi%e%K!Ɲ@[F=Yg<YD,%kdy,\>qU6)r= gR:<Wk[B{ߖ־*;1shro(˦e-"?JUdJN.&G#+W:'dzպHUxGe\}`2(;ʻdIF숋HIC}#Q~plɑiLӧ`dcrksc0('`Ά>P|(Q k [1y $:ռ;7Ռ'7wߌjgj)B1S,z'A1ÉݖiiJ28h[u=+3<6Ae@ V4dCJ-xR*:ڧ$cc=Tkv㇠۠ = {#k 2C4Eq6K[o$$V cUU(8H@Å2'< DlR)H _58DdXkUDBDT7͠?Ip՚U`uYWQE ]fі2|ssWiu 'G6<*ɋņx5Q|GQ9;oGyawS\7Xuh%{$sVMGQ9;o^sj% F_o5 %}gPǼ+qM5]ݮγћjl ὗHEUm:\)6$,SQFIWJA1Jq"NO:e$G,4TѲH`6,H HgYQ$ "ugrdċMoMoY ki IaIǫ_ FI}JoڛsJ}C_{~éj9x51<26"ncplqMoMowRߵ6'+XZ)7nj'ڪnooG }$j6FnhBŒDS{sxHuL]d,&GC1C\Uyv+[`yY֊<CJYcý~W@=T浌 x6XUiH).d:7y*GL!aN$6/!ēҌzn*<^V.Lr: 4.^+܍1 Qaՙ/;o?% CA9fI?33#3@#u/u81ځKlC\Xu)^ui?X5Q{@QmhFGMoѫT4j ,.A*$[|zIEd #r8$ihq)Ldox$ȹ6:M D ²Z6BN̑"X\Zng.IiE Bixm4qH]u%VPo` {b+EA4=񜊘XsيeEzW9W-sLy+%>!oL,u4Mq4QL&4vG3b+9cO2p /p㱕w\"`ljM,VďM[ ɉ%X,!!DgOI0O]gMW[(!ZMGv6Og% 2asDAc49J20&=赀mY8\oZFр @˦#5Ö%46n58ךH?Uuij#tBBef [Zt%&!d(6JHJB/I@%6$[^fsZ4x XMWkQ6m^IвֹLw+FA*JBY :j;aj=PQeUEMoy;TZ Y W*ZF A6I&v:a}O# EƹpJl6 l<33Gk`8#mL^BT2hTM{L}[ǭhƇI[#qU#$:<>jIl8vȏ+REܙ 't2CnbrfZW5ieN N?y<㓶SZj4& w_~xݥy\Ǡ=3V =-Klڞz覞.xAzKY䙇L~콎8i`󡥤WΞ &ɍPb~;fN@a5QwX+)&f饑-S}uf1c&\i94/jiq0[ii$c@.1b@qv֓hBE稌S)e~HY:(:*3jXU|ԦG.)*tSȡOY+` GQ@u/0%qmsunaU3IYE5p芔4,dN +E.`F,8[9(aSb]Xj-;o(b:ѦUYaԍ#ajL.兩ʟ3xBK婶3䑱PL X9Lʘ 1 IS_SNh%3I;i@Hv ⬣*i[# m;5.~tT|Ov;b}7_&i/|~*?ϻ G˿:q*>`'ٻӏ1Q>/ɿly;Tv$~? <b}ߝ80ݑ7Ma|ǑoO`G˿:q*>`'ٻӏ1Q>/ɿly;Tv$~? :\iҍTqxP=J {{lǘf2=пAۗ_&il5q#aߝ80ݢvƈ* z 8YXGu_"G._zRk@'O81ɿmxt)22O:*1e%{GdIC#[Vbƹr=bv+V4uQ sSO3v/*;`ǖ3ᚭ:HDRQQ`XR@6|6is2K1% =:ɩ/|&cU!# Q"Uc 5iJl1fYy`5g{@&[gzΜb@PƯ"VUnY0kK15G"ƃ-|yN>SѣdfVMqr>-clE6=|vWR2GFT"X:qV'#aKHr9AəvV6]yq&L8-sth!T-F;&|VAYM4ѦpJr4 S>m$U!y[%ȑY5fl0Y-P\18kUUQnfc۸7&bشO"I2L؈ #b\R@*$tZގa|rmfj;Nk[kN.†Z!1uC$nzDK( HvZ#l/bfIypZ(ⲽׁ]D=Q:HdT{߽ӏ1Q>ۭJZD5o[GvL[.z&B}X3s4f^*_i<7MuJjzDI&6نUVefRдR cx˭u[j[xywNʭ HPّŇ f|agOH_f&oW|1 ž^%nTSv˧SToK ~=]'k>ytlR6]Zoe}"BwmL8ONb=Y`HWY]8фpKF",buGpVÇ]uF̓ߩ;BǗDY4XEA`͑Mё[(r$^ª1GX#{!~Iq!\•%tsL'8%*8'4V""zAV=-)Ԋ[9WX2]u<$f rQLɣ_eٶ4)&0xl"D+3j8 (ig~Ru:{9pI6*ȼI "s3o۞u^p1O!vF۱ g ,:]$XKzGgDjU6K"LhlƵzLJ+W IUڳZaySY^9Yl5Cp%Y`s>`آV֕X+&K%Ic02 j4z%oE!eTNguGWG/y=Qu%l@jxIjʨ0,TtahL $aeb['Ok/||'+?(1{]1dr??lq??ly Oҳ>Qcݎ.1dcyv6/6/gW}8ϻ\cyv8l_,al_,a)?Jg|qGُv1S:h'{])zx_/X|?x͋6A{yV~[}8ϻ\cyvD1F@k fc,&b:s啭𵈾i?| L}ͼv+_&ڢt!FYDplsl9@!C ҲBd4MaC [ؾYe.IgK5; C^W{ ֽ-c3ex.K pz]9cRi %W!, ]-`/ 9HB8A7$3*R ʵ'6M84"f#&]8gu,Mb[Opxp+vxȽ,140&Ϊae), c\B(ܑTP}Ycw/&Gb" ffn651'#Z*ѲVVv'nE en\O{ήUz]\1=)Y1]Տ q! b3ĕө<\JX-z7IS(DR>A!rс>,JQ`'d ^T# F DyvXkafDR+oY{A֨#A (d: bTj!!>SCWV^j*"ʜVK22kiϏݷ4bl^d6GN9NGHaDV'̜) ,Nw˔JGגnΝY{'38"=k1oJGNy eGN夐]m%4 ǧV@}%kYeId^M[atMŝyarP1 xmc:R:cERr Ǭw\lGW{]LҎ_ IrW.CtM)cl~.cG g 'bg PY%.#vp{^c4k<(]]e +AQ8T7(}n#a>D+pa-NK L|VxBȐu$GH䶜OTun|=Js!(2CLNsmA:rUVXz)w[YD Dy:g-tZohp,wʷ}Cp=1m+F"HcmN^6=8;|yǎ<h`&n6PN+8kBaIe gR> w#9pǦNuLn)qx'}`p9o=aخ9L*Ѝ; 3uUiƫf,ZoF2k4{H±vkN#O)8dFl~+Xf=sט`_TZzyM薙;7=Qc;|{a2N^T'u^HW1z[8fZSYmha/uLm.A@̎VjV9K߾j*X2>Bt:4 NE, @ T ,Vl& *>S{-n.xKvUY۲o≠|(cQj2um} .{$p IV4K y>)A|]yK1_ohOT|~[[/<}?[_F}ccY#x$}ǀx$}_F}cc,уXcGa/>e/>e,уX %`n6<}/7=Qq$] (-wU#<_}x>eLj`ћt5#USKlR?>О 0'׃춈m]c3+aYS6<)m:dBb5sHU5^dv11nEtדҒ6)&ShLF+iXjseWQr<m*uPwo pJkUvUsE%ş_ﯹ(m㬊)*9Et+wpӶ'RN,gL'}8RPec͢G%X=\m&0ymnL0fD푓ܬ |]:b3$ɟ#%JJ!g`Z.-}_2$EP\~VS+a̅ Eh҈tE'(ާ"5h䪩 [2NKv|@#i4 {kmV;\^l+*INjB-(2L |vo䴑ӑ!;C/>eA}o~Gz͍\Kv,/%!*.9l*zAl+ʼ  %`n6GCJVmj;wj$KPT)YuV{6<_}x>j1b[$,ӴE}}x"oc l>X;IKm\b2Yٔs*MXV$ҢHZ Phs'UGzXo E$_:Ná\8g(VгwGY[kJ.AF)TFhX"7U 7}-ɵ GnP6U6.1+ɭ ,jIZh`lN)aڕcP"İ4SŖ2eItl_+yKNx'6zlH[42,h OJ%QL{BQ2InX# _l+kŠg X3"hWqÑ8mwZjdɜV՚r)M.g\[ @=7q3ZkVq BHaJ71ʼ\&]}2qJJXDlfȇV9yj9WpOɫiHevbI6 ,hR#aCãc8c#mOgq{dS q%ő ݾgg)dRЭ 2 M4H5E| őI#miHFۺLQyu=U(v%PVE Lâ)rZEZ(;&]nFlGީ;=9Rw{'ɫbkB0џob̛Q1ٌ(V\sjqۄюl)fFEg##㱯o%,cL׽Zۙ4!w *n10$JVUX '}'!=7NOe5f{ҥ#ήQ] h3"P)-,Đ? uA?e+)d3#N ƎIB*Gy,G,2zooo'bJPyr翰'!=7NOcNCzoTYZDznglfԆ$wLg4%Dsj3r"ElztbIfWT(• 8;g:MsE,(W(r5oݿ HY}±s m,p'}'!=7NOd̽f6/Ҫ钤K=tdC16^:u SȎzqlidABS@Q]50'1[zib?rM00{6~*e:H&"_l3$j>@=?#XfxC`䎩G =ȮkmrIs3N) ϕeh4H\s,[/) 2ޥsj$ *#Ðkr(TAcHIW%`)l#:,0ˠNiuxrXw݄'A k(Vwak /[k$a{]&zP-?WiJPކpկH+HcҺ0r\V Ax&?%4 ec-mʻ5m_Qqf=֩!Hh;`"ȴ. )ъ Y9^2:GlXQtW}g#3j%_+jVJ`##T,H@lPFFT);هU[6㾍Ć5 ^W֣iDkx8pUUVդ%|IeH2,"?_O&k_of`E$[۵ŷѩbF &j$qa q&"#F1T+KD6 ֽ7/㋨b5oQ'lTfC$Jɞð ќQ}\/ )nK $Jܖ$AC̑ "k&!::G|#5;0LG쾶asc"<Ҧ)]dN8@"kIbCKracm~Ȯ?f`SPB#KK1%q+HvM >3S,|'+ 6EȺqlV:KriZax-i[_Rh4X,,$ɬ]1Ae,JYeceȯ\X^Ov\mutJdw.Kk248xn\ÔR*ah\49[P%㲴]k"VP^O=2/OmV9A`$mb+ʽebv8cY E-2+L⟵(/5Ե4qbHNĀֿ=@{qI*ڿ2McD8x t65ԕ>N> W̌вaD$k6u)4^Kod(ev.`V63Xu"@iOdC^üZe?W?khO^lEo.%jNNOUpA(Zʜ+J'A$';<]Q52#p &άkzwX[iH iY>gʑ4n)dD=w&n#2k׳;XO 7%{ 划V4c{BՐb(.EtsUUqg5U}V*WĚ7hxkn<1\M8k jnN65٬mɅgmtfp?Ml oksGVK+`[I{2wJx}T!̱{-skr:KF^uU]x7e>ع2nsKR,=WQ[xXe`?rBaa 54r8p7' 1lOȨO'MEEMdz*qDTűDTE'i<FQ+aցPH!P$lH[†(e&]M~۝)ΠMگO+pd ,rpHj fexӔ$8 xqsM #^ĭ*lM}Ļ@iRPB5ۤ *#1W'wW?ȜE"9jDDbx'yѭl}[!v 6yw؞_cV/ն2R Z} ۘqwa1j&jEGWFMzG9c,ąQ!{TCGv{2s-v+@3mj \!tGJU\6r[jr4$B26 Hrn /"1b(/9d45O.je;J\7iᶸ\XM .rqKdNj mAXJ;,SVfYTd &`FEhwSZez*̝I,lH<11{aB]+z>gBttA"KDU|D;ܳM/rG0RGB`:H c?K1ḱAtQ&(X29b5$);K9ooJE# ֢²óזbSޓdOR>C8z8Sn"BxnB6ㅉI3+""MXqkQ㱲eb5R/~0ֿ? W &k]-4F?lvCC@ؖMY,hc@8h-CQ6$d44z"G d"HDV^U^N<8>ۍ_mNvQ4hJ齵1k\sp[B ZO.*v 0s+cG.瓔#bs=rUH66c8a0m u+c뱱c8,<+W+ccc[pXx W]+WƷ8_λW]oa1tk\5VEM]^gc8,<> Qůp^ Z+ccc[pXx ?`Ʒ66665~'c8,< oa0llllkXN oʭ_t}|!f<؟~>images/schemes/gt.jpg0100644000076400010020000006334507432602224013403 0ustar alexcvsJFIF,,CC" S  !STV1RUW "#%37Aav$2&CDQqrQ  !1"AQa#2UbqBRSTV$3C%45Fcdr ?46GN"s_坩*T뺽VmNl˲f5GF b_m&N&꾶XA][ZfˊˠA*b$4Cɡ߫pԻM[c,EQ]!qzsiE-z03WKktT?JJӺ;is^7IIN  H-r0ROvy^PͲlUxBR2K9a&.S&i #%*|̋c@.[n6:v ,'2ף)11lm#W#fɨ\ uh7-DWN2U5՘Ɵs)0{! :~}BGA%CFR:16QUf$DIJ wFZGRkea:iNjvS3ːF%|:]u~av'kR޵(XzObmnv%ywGi[+-N T=[.itt6HH:c)Zy1%ʫZN!f%Xqk?.SXզeT2 `~o'?W=hs(n>NZ>ql{A 1wIRwhZ;wJȽX^g,xOspɦgZ:Ma6gz:iTFYTVR6?H(/[>(,Mf 4p4j%uAle9O;Di:{ws(n>NW=h_:n g>;, bq)8~Bp!,"g\(9lnh )n,S+K@-o @$9 q.U@UI 6YX6 tK* ,ؐ=mm\n{ P} *1!)cdʫWyQceSGvX]A$X25,h*'vC{Pn7CC'GCq4?t-,ulBK0W[7j,FY YG 7]C6m#٥PR'TKR{(җ$%ɡbfX0']}24F$r|B7ċoTeUM RHx3\߸no|:ɵRlW(-6Sgy̽91wc  @6"uPLr%T!85-< OgD(2#jsV.urd=ce ʩ8 k@#*|h #u1?3ۺUFS_I xc^;|l{ i譭owƱ{R^mr_Q|iV~< &%y. {rapjZмZ&5Jq̰)1 G[| rP HRMHwF,4K1_ j.У/O~;{MN{wH|OSŚl Eq5g:e*GLH`&%wFrnկGkyeɯZd8yƍF (23/2؇Cb[ZV2Y|3Yf:"2i#1; $3ƼE F|=ì2N> 2le|Oe(e@:6Zi``&n,̣Rߥ~# 2ʐ"g@m67_N-_ieA6Gkl -A^Be(X*[{'61yϦu9%,F|}׬Siug*lO_P]y7YIAYǬC=$## ո9#cAq=)zC) BAmb0P" 9o,{bwלTm?y`т.ov6llCao1=cyβC#'n<~cǛ._ޣu>jDMf*[Zκ `] zrP9Rba$zqؚ Fق Ը0C:Υ"Rc1c؟*_wcđr݈&AC IKUFʕN*#6S}@b;xlh{ FHX-EQH ɮX"& EMqN9Y*fq?IW 탣v~2蚦ͫܭmOҬ܍]k'eݶvӓ^`mDY|0js#ѡV5fHX`%r(i33MD5*BUyk++6}LGۢj7v;VUZ|UfcTbps=|_w[]GvVkG׳p 5?t{h_Y;6r!g[ oxnӿch?귄?hX>h_Y;BMh˕v{#VuDV@죐x˅ d'GTFO%Nkn..G[PG2;Ӱ\N귄?hX>K;WNYvQq\oocXE,l}JS4Sɩ7bBf9BMhgV]$+WZ-}l$DPS2ƺc0DQ>/Gc>mQ2`<{b09űiЋ(oq!wu|,qZ4=#{^R^M=zH+ouVkuL0uřC81quz\`ٛz_e.I÷,NK xF]+bFEhXŠy ³bWE@ڽSd4٬nO;ߥԠ[aʞ4n&׿30o|yEnӿch?귄?hX>Wdz?'31_^Cm#^q^n"YԓTqY]d]$1g2(tl"! `f!~,9g̥w5g?E!{xb)3c>KLCTG!!fqGP{}bɰRI %CzT ^:2ny:Whfv$a 2}7h_Y;^|ى=ީbD՛^%j>blikLDQ W$brNV):`А@f,Oĕ:ج%tUoN>l- \4{ c:g[,l)JNҝPN1: P]Xi"1eWX\Q"*`/ЂEy~Խ]Re(nV "Ukw))e7i\eܣAKIGwS+Ma1Y@FNI0[E.9),K+-@Uv^vS,fؼ,̣XcYkm^WUtMvMt%vdWň E 1 8ќQI6MS\q!OIF"0PF IH4ꝁL00K};^q=5t{{iD>kxao~ez<iO[ݖg5t{{iD>kxao~ez<itsoG?[ݖg5t{{iD>kxao~ez<itsoG?[ݖg5t{{iD>kxao~ez<itsoG?[ݖeZ(c*#݆S?,]om>(c+6~v~X^lߝO{=I>8 ۑ-7a|>qkZ[byYj rl5Qu@}+(Ha`xQlߝO qXOg0}!,)^0ac f$bY1 9$cK5H9vUh .@6Op$*y_Jv6N͌tJ;&ӻ`}bc A]vEcMʒ%g̸N[vюPh_ᑂڳDj%Ai@i#1 [ʌM~ .lާDFS7g?{Yk/Ң%JƱ͂VRxs V!@$71X$<]\ImU{F܅&UNH%' MZ"p}SILNL}7Fom>(c,;Ƿv-c`hzÖrI ( ]  31$Ex"݀A`w6!zٔq= Z@7w Nwfr>¯#C~|rKHMۋ"\lQ0Yy%&{{iD>kx]Fg\ͫc-hg`4 9q~|g8}84lߝO􊹳jF}ֆa")! fн`F) /Pæ׌\okg5t$/uamӓWJhHtBUz*&t".lHY$ ~SM_|iXCebVNeBsbĴ7KUHIu5|~a&a2)ar;c/ ae|e"@C =vI#3WuH⌾MDثI%blGSYAJVX{ig4.9#*9n2]o(vѪh6?ؗP%@dn/Mh,0Ğq2(g %'O)ͧYDO2cFr\5ϝ- hY6:5Q85͙qY֫u ($ d w9cr^qoFҜ7983,Hז 䴥5ya5~fa 2;kP #B.[܁U]hsA]dp3gW(spzQz|}|!WSR)R\-|ek +3*wf#dZŅZ0B@mCu֬.bLhdpG%XhOhp|/Y,AS7Y>;z~Qi%2Lq[4EZ΂\3dƮ~t7j=V2 (,Xga/دT6 Mg Z]T4g{ IT$園AZ25/cVU*C1TG䍨5RHhx5mC᪃ `Hjj=Xc"5 7lK !m{Gz|<5יWڎgH<8 "9FWo7 ƫNcd+xX8O9!={9(<ɸm[6MŲϣ*9q&Ldy B s +ͷ:Et^ Y%骴~ f7Uk-rd0,ɪk(g(" I!H-V,l쥭JYKj:Jc#QHs`"mVlRvé+>t{sϧk]`:<YYFPdFIƂ:$zB)i2̦ y}}A/R>2*Y9SβXF;b/lqESOMI/&xYd6 ,@#tvc`~1Y}ˣ;V};_r /_թo~Q}Tk|oV'}gӵ.`~1Y}˨/l/PKԿ{a_V?ßTzpj[{z;+>t{sϧk]A{a_V? / ?U;ՉF[e8kC:sϧk]Vۯ87=!Iwz57asW8_թUGpj[{z;+>uR=)oVyŹf%0y_'ʲ0e\w &q!B㍧ /T]vVLЌe,i#g1sj&b_"9%, D}%xvU#5PhaXѸLL=vۨOj!QvnA1[o:l*S ҅Xד,c HY E!v7;r+[!$!0ji򱢃$ʰ >^luCyRT'g*+}kzXq`a|IM:P*;~Vd 9H>S8K!r9w)cz͂3&HsniQqsp'0 ?G"|yFGLOMyoaNܺ^ ^?'*jPoa}rai7k,[M=1'`QL*ZĔ>UA/R%{]aķLGN^7u0jbĿ}HLY̙6p=.'c Ҵ^2tuFЪS!w)K5D*Sw_wq%wKcCK=ۆ+mztix;uW-|$ JE p}gӵ.J p5Ql#*5E_aNZAbɥ%!^;< Y-3_թi{mTs+{ㅨϝw?v_UvC (o45,;I MR1,F-W#) /% TtNvhb^7:wAlĵf X_A,#d?+#Q,9\SPV00&Zn~>L[ڔlIn#N?mkooo݋mU?j(RXiuyr`p@~{&^”%ɗ9R@k%dpҷ|-.e6v>k+abF<#5\=l3(”2h`QC(\ bKFm.<**Ի*j S5mN++ZsGD'R3L('X3 K&ARDiTH/ `9yryLt}z=XyMddTb02;Jł;u|z5 ]'h9z!yf%.s߈Vs{W#=s?uڕ٬|s{MLj( fy@jk׺v+}oxSk*@w mOfe՘ǧ C:<%^>^۽*CEWVآ=pwUٍrዱ:0!9c|SAO6UӸgCr[Fƅ]Uu C#Z}C6XL G3q^U@}?$P<}dSա#/2SFaf-ŧ|i@tP+ G \nSZU>Ԅ(iΒG2첍mܭ8X Tkζ}Kv{fr+%zйŒ'3KXQSǔ}i`eFyxn+蚟#nX4+ ZtjE8TUjdÙ D5Gus쇰T?HW}ll3B*1yQٞ$djNihb˪b~Pl̩%Fo%o~E~^I8: :H!Ij*d$FGYvvsGc!kY$'^P1d7 \ jusݿPKݿPKVcajº=µUג:w߇~?=zqo>)}4o>)}4~pgt_:w߃Gه?vCSK.vCSK.Z鍇 Ll?MWWEɏ}4~?=zqo>)}4o>)}4~pgt_:w߃Gه?R {ᔧ聯wp%zao>)}4- ֆ(sSvMWV,ޫv}µU|;}fl;_vCSK.\˺mEtAe[$U Y@/)wpħ6pguH.גLPUlYm`ff(STjai2HeehsmqyZV:_M͵Z*~oʖnέ:o{-~ZY[g흭nz,AlBP+B /x)6Wm~Ǵȴ8`#?46]c-`Ťfv^SgI~UvsUJhȓ쇅OU\(=R#찲q 5'dMqZFE#({nɡZYl,H٬T 80!a FBEʟ%A8RiZbT{ GP !f@ڀx@'{_[vCSK.;[>#'֚M*Y,{iR-q&lc̮h~n&spgunInGbySl,'@[5^M^`}dnIu#G>139 U#t1pΣO[؃J?'Zͨj@lobmmWȝw+4Н$]eU֢͛hË\}a%R;em=n}/OX&Bi̋!0xs$pªt de> _bbErqŒ툵$KECkjaFQAa}IhyǍ Ƣ_B4\Z@RLJ+7 UG3=%ȱaIt=Kot,ұܯU툡x0wjOƳ16-{ĵ$!=u.squu@ #i3ϱ7G%086NiWQU pq,acēs)c1g+7zhe͞ҩJjMǜ.ኸD؜dH+?1eX>Z鍇 %gswfXkB;okm;at2_ʤQe7ݫvt\{uh[Md{E͡{qE lM+پ<$pxZ|H12/]'pI@lW;[{fMDezC3Du^X5@k~𮛩c΅{\ՍHk]>n;LPS+mnY 5ۿvCSK.:_nPʇ%Le@i-q۬f&[s)d7^ 4 4h}µU vC%ũId -jX :5է#\ƽ'jFqk Uъl:nQS,T&V5Tƚl%AP íMc/Nd* OæQƬk7?/= Lňύ<c"KHXL W8FVJ.q91̚dC(.N*Hr.mb-% JK̘2t"/0+_o4q4IlX{, 8'c'0 QN8sڮj:cAB!h` oΊڕx:f,(RV&CB,A7?[.l \Jl 9*!h,=y{Gr/izNzlq bԔa9(,Yߜ?C?=X&ӽu[ N6_qne&m[xrzn>v-O\tzkafTF=}gjܼrUJKԝuЋETwlUM1NXsȣ⭯itfէo\~gG.E:{e4=?NM7z[A?_ X?|Mc_Q?=Au-ߠ nά~|Mcol&1G/S`ECGqk=!L{A1?.s/]P]~w'u4e1CMw2Ouh#r ui! nΫ?HD \-tH}yLh5-eW`,)a){ZW_Gז*Vܵ="{lYTf]⏛f , Dyų*n6V:o7vڰӏ|Ve:5Ul!ܟ,Nae#'hoil~藺lH,J]f{aC+Dܔrߖ2DZNʦ:T5 m{o-+7uC3\˅* r<+vh'\pD|jewlpt4 < 0pD˦M}@ތ+M%Q|oV_P]~w'ug8NڲR*aa[iU6nlJ^R&o5qjIӪv}K7Ԩ]RYZQfM01e(ì]x1sFpUQ## !8̳B1e ca̢+c9\Wkf΁IkY:QYA:b@Hp]iV>mUWVr F5H' 䨘`L̦OG x)K=s礼Yu##pQ}1fl8W&M}:. [\6͘(R(zB_,ov~gI֭vn(*kk'"/RM݋v}EWebǎ8qbJ 1|Mcd;jj$`+Gu#q\~gKt`5M:ƣ0Ƶ welH0E< "r#{{e4D<[HYZl]oQ2lWa2Ρ/b*+^ څ5j[+D}ZRuj6@,IirS'_u#TȬbr0?ryw7׷6nrś mZ 4V]r0SKħ9b83)g9Zd3K+MOfIezPKNPNwц_.oWAZY;uJXճ3NJ樋+ I7 7A(sSbK^OfTg@qʜ~ղ.o7XU 6$OnEuoFmaq̡ج4%%r{nJwF knnrki(E )jɑ$<-WCS^BV5T)>R(R,gQSv !}]B/{~L f9c ,zAy$-KB.l>X,Kh®Ng&UɊ"gy1rnwCUv\wm*sa40iSlI@,H_~?.G1fiö:Pƣj"*IfԡD5|0m 1gqw|M|IXb i6W6"2R,9K%קgTSpS22>HHf 7< ~*"6[MZ̠,R<`cMr m>,Ώ?e/g;p:?忲_ 7}쿟etuXo|=_GɃ~~o ,~_gG}3at{uXo&=?N[%0y/Y}~_gLϰw_Wat{?9oSlw`.,~\~^쿟et5POYݖSn'|g;p?30>}e ~Oy/Y}Bl,rk s's׫8V0pIx3!fSq3O` ì畴ziOw >Xr51+xu. 3 CG$r\#)*lA BzqqqqM"2{ˣ-bP؎S'%Fq q%qO!s0)M#`g?{X{-Ф%ʶOfILbFF.'XD;ǑyUp{WmWչ䜐X;g}^5PAJGm \G+# I2)YDqrvٷ{W6KUfYk{Qk0uFw26{=[Dc .oxɨ ,"/ȯۥ~QI=PدX?e/=VXf&sk$Ms.pcPvJ'k88GSY탺^WH\dkq5E59$_ !P_ 奀Jŧ7[v|[abKP]^Qju3Tc@]fĕ"v~tϝ"L-iIx^9؈R!nm'm@XbM+Do{5o=\vDɍqX]NbШ,vK^| @~1x__Ͽ:0STYvleW!F--/[.6VOcvGkBI7"řˡѝ%)+-ѶMtXy,ђax1E"fy*ȳ 2)B?oNTp{#roq%CQ(H6,b}xToYl^Zl^Ǡax]$\f>Pya-K>곬hnw_ڛg5wKNj\jOb6߲J\d,V+\=.A+3);atzȡҶ" @c{`?k{vt~542E#`, ߽]y/Y}*0,Nَ}fF bĴ78VÄG1̉q*TT=A['kQ5f8;y$q.@ᑦ[=~WN3)C_ɨ DaW,Be]BbkG雔;uّԓYO7̉40IHm@`H6\YOVxj]RE|Hc6VjZ <[X (p7Ȳ{tD -\Oeńs Uwx|^y~x/˟9֫yKSe7b=&q[Ug><xwcX*!EErdmv$t 19L,ˤrac]*pMV}$ƖX' Xk:w |uدn,UfJ,~wƀ$ fR뙝}5Zg-Xl;)eD"ŌӨC.Cr-?RSrG'9?ŜeA9xJUUz~#By 5I e<1Ou9j" ;5N[B0YzvfAW"saakԲGWP9ĺ`Kk)5U\6u*UZK3 ث%!L5/A{'Yle~=z¶l+&{-g9)Fx@!3`omWWD *S"x0qݜc8a\uii^%a*/Y ZGgd Y؇MzOVc _>gܤG޸Y_WծϹO^!?D(3A5/šH$RVV<܄S˖KX,[F+3z~(-{H>+ߔpsme[Ylm\2[moPb.}_J//φaY$o]='<Izᜈ-cbOcʆSTĻ1O2ggfn`Y Ý) ؂,q* ZʔI)x`=;ՈpzouTv\::#^Gw5W nYqx'R19qzU\UTyLS=FR\X%x™̡L~4LPS.y׵onG]htsS;ܮ@Xr: e{=7:=AdW\-y Z%X;uҼj qOXjKb&Â6('3(x'תP6UQZ!{5bIIy@alTZd@g[,fX^Z׹-QM!{܆ Z]l~PGGW(?}ìN2`Nw|n8zʣ%MDir`XdL"GJnpSfVpJ^IX]WiZ6}"~LK,b>{ER*2L,JsQRS =R*XԊrs9OĪVj!z u; qa% Xϼgv=A.Iw/ҁ4ݵH#,B[8c.8̡2D(#"ϭw ][rTM}~`MLZ魀, GόY"Ix<bʳ% W.kEHAZI++Hfo߈QUvcm^>^M{E&j13:H/S\͋%LR#,!&c,P@v٫ݰIdmS^Ʀ֪ԪY@Oŭ̈́&H&Ygqϓv6^ja팂.lV2~[6BȼS̥2a6c[xW[.ZA:[pwwVXu1Қujk˥Y}97MnvnQ0NbV,xElMLjh"#Ō"RtpOU[[OrFPIFӨNt mbxcN Je{=7:ölOR2\`ѱHGG^ESeqY+@ũ,|Go](j QQI,NyU@x z+?׫GЯ&nX7ٹTY0㳏`Sʌ[S#kxX_'Sθb|!n{Ϛup(sZ^8 2͌L~.0xFU{4}+S功1=GpC}Ǫ rI^m[ZiԸe JA00W25ۮB1WB01C1c1u_V?>](jXΪWy>܃>Ӆ҇}أ$xT Ek4 JGcD X2},G9L+ߔD.7QŒ`8*{cq߱Lcƛ w6lV:0#YhFI%O9XMM5yXU #{#6۟OlE?]O8eA$xmxu1ỎJښZR)LL2(S3"B"!n lj ˲6Q>NTEXnx(GQ~ic)IݲuYdku*qJzO];ȕT1]ÉF,2u:Kʼ«P竤1o{RKe{-$RJ4Ո횐v8edk`hS<יh=bqǥbG>5VCF%N_rfme<@@P <`F9qG ۧl]}F5v"2L-"+@*_)Emos*[5OXܝj 7&%(/x,,g/U6gK,9kL zʔv Y] RzA쐘!jd>kFw{oks4ݷgݶʽgX=tUH=^ݕ"^)Lc")Q3]p:8…"*B.isYT_2sR#Jsk)׸.(*n[cbӺ%SΞru}w oPQs9*v}-㡝@ßkޙ9ve6yKf 8l &. MP=hLHQM"`%3ku%6J9y 4:vamP-kfO^5%Nxl䫵.R(1!`̸Ć@e[z{}tm~.m];WsZ,-EjS3~jUU` 9oIZq&,df%2u^/uuxQ `[bԸaap|N?lEFH ~ 7OkWb*{%֎Ets[M<mTR)(~P%Mߨw 6lzt`3~M*AUV7ᥥcaq d 3%#cgOWVy4=/ZFpQZylb2BrHr_h_GSߤ9/r/ di#˫"-gw2o\`i'{7:{:\SI+3ˡ}iʢUa ZlbPd fFN dcqk$ƃbmbu,k]s3]fpKkA0TK>*{%֎EtBe՚. ^U\H:׿tU& }f{ ^Ne=$d扣j;sI+=ֺ: L3']qflϭ4J>!`yt$=6:cU^rz̋P Y-c x҄K3TK>=Z_6@l*f*2NgĤ!7h( L(mYD:U\=[ %-o{KW,i8S}=E_Vvo{|6ɩ泲MGF Ua/&K$ŐH10o :~ŬmWWR0mA"0y Xқ<\[ܻGFXգ| kL$ctIPBX ^ǦBM$[{}c-O6 :Um\ĺq^CbBJi/J0D|a["$۫s]ڇ8o:kS0 my_3y L DO ?%k@$$rvíU+3v͏iǘnE#cacFP^>Ƭb":1LHVbhV 8N+,{?^Co}{.:D3,i,"B4mXl0I "=Z߁tz6W׿_yތk(m~׾P_^ ~cz?w"=Z߁tz6W׿_ޏV]{ 7z0j>b#կ|G^Co}{.:9ތk(m~׾P_^ ~cz?w"=Z߁us,A afyħ39ce;ݏNOcwaI%-\cSYTVYUYe\a0 ?/'OKg8<|$tޏ0 ?/wx} z<|$tގp'OK z::w;>0 ?/'OKg8<|$tޏ0 ?/wx} z<|$tގp'OK z::w;>0 ?/'OKg8<|$tޏ0 ?/wx} z<|$tގp'OK z::w;>0 ?/Lc3c9;ss=9—images/schemes/maple.jpg0100644000076400010020000006561107432602224014065 0ustar alexcvsJFIF,,CC"  X TU !1S"#QVXd 247AWv$%3Baq&CD5RbuN !1"AQaq#2RSBTVb$CUe34%&cdr ?*RB\O˜QDhZk jZsE F(M+2tZN\Ѫ6GQ7spBQwC}+l\s  JI*<ళ#"Ȳ!DO`q jLRh*|#AÙ?6-VgVTD8Л9I;&c8t3ŕG?# )42Vi3,7TDzj\JhcڀzQ-VZAe7Mm+I“:A87nF2KlY  &;!Nf9# Av u2jK4,ȢB@bT=@O, o 6\ qD=+%lr r^A_k Db+)2C&O87%RֺuC&C1["Vma6D 6͝ ,>IRtOe _am 6OZGNl7"nV'Ѱ7sCA#F$ϡ]r4I{]Us76O[Nd $뽱K=X&?Al4GiX _#B+(ro#EWRcˮ¬ufGC[{bQedU%F]7 g((x-ئNQp.Đ,;Rd\HoI}x!1ccĖ 7{,W%[Ñ2(;:쨅woAA[!3 <4HccZGm1v3 er ̭Dwpuf799͒Q cʏ9Fu/GFG4kb*b5n7|&Lg.$FT%fokĖ 7{$/L鼃6z 7&2 \Rᑌk'[~ +06p\z$.HXWD 7u6VQMuL̊9$ R jL]IDe@]@-Ee*49t"t;D(;>|I`_y<]e n@l-]Y9Pi9W"2;Î[cR^BN֢4&dFtzD"0L1G aGpc7P:Ô(0rgdyJPeo4*K rC)#XLHMGSD$"梅loTefWb̠ or{n6?$/L鼃4خEzqt 0 ~icXҒ %ddxs9 z#EI)rV3%vM\X4d KE0_cOu=aYl~`6gͭzDq{` FJ6:j%Ԫϡ$!rΛbH\_SNnl$.q L^$.W`oiTŃ&F 8ƙ$딕(㘪1Y9F^ k85~-kM@!12 =4(XD{qr'7++9zkpTҽب-ks 3vyviCMZ5,PI@,bӔ167'Z:oU`1UjY_I@ds./[K kTu4Us*#tCiu$u\\>5RB/Puj Y1 n^. +]I>jiWV>ǃ,ʱ#hRtL..svdykȁ(Q>S.Z" qY IÙU%<42,kib]du*v`̊ C:8ksgO-%W, I9\k*|ݥ%I@_7iZiT_ƑQ\>E /N'ůߵ]<4~ |I?/{cnҿ{Z~l~JiJ\>E /N'ůߵ]f~ğ#9+*O֟?hu_O_jp|ZUgK~ |I?/{c*O4wZ8KDUU~-@UUU|ݥ%I@ۮp|ZUڮ3?hd{QO[?t{QW1on`jbٓW˜)&f QwA1#יkQWg,ӊts}ַh;_44HPK+ y8άR7rf$cM-pc_VϞ leN`{}GYr4 hcğ7i_=?IR~6vt]e1CC*m#ץ7%05bL9c:ڮr>.LWhu.`uºՉR& ;Uz0IG .])ҿa|JϿGxI^ud PEn>\kwn-e^CLEmwfPt^5<Ցuu=𺙖 aăWEbWsR4YpUr' > }ެK-5M,,tlX($]d%밤jTPo;k 1mP챨"mfyDrťp'TFQ8Y\O;H$Jk H l{R#;ϝF*8hXjYUtAFYJiJ9wNٶ#e&ιlqښ-AfEgKq[( hOY_O_jfE(#+\v| n&8#.cyu&`s5<05 R WK,% lb l~HO̳\GQkC,X6$5p1N->M^O+sOa.L8N/ 2U %Ql9n I4.C"֑ȈsF? Pp+9ǨJ#ZÊ*ǷSj}<Z+YWoӼml"[@So33\BG(.2h2-EmX)}ؚ'BtrH c044D 6^HaGnQvf׸lg\H]GνBlMNOQn~JiJ?tդc]b$'Ǐ5'qpcd-3&(uD9Z[sBGW9gKx<")ǎBox zj9#/c*UsU[rpU$d:ACu{7ccpָ^! ۀc?뛏^ rim& ֺDzI3dj1[LpdÐ LPH@N 6sCtEdMEݧx&eEY%mmLq$F7j+I'"dczU]o\uwU \mfàdW&äB3!t' QDkpArt>σo<<)Y΃9NY.DUjXF:,n,g1Z߽OMVśYVXU)7%}8#8zP,ܩdYI,F襵nv֟?hYowQXͪF2^>:,z:!2Ÿ+[!H}SkWen+-NY g[<QZյRLhXE轮vM2)VVHRHX,jp$[|;q̏Mo瑫 YbWHZ{b i"{6& 2!'Vds4 opuB$7E3W锈q5 v0ٓ&BgDedi=V#_ gEcn+{Cg'a_$!7M|1&p2h5-TDmiK-N hHHWj~ \a4ƥ2] u3^tQWUi%@'RDS#ѱyJ q[EQ[<1G3*si%QKY!-#mFV@"k:MƍmebvdL"(qҺ1d2^p,*'T0l)6b4Tz'v(+!Ħ&c #Ϙ+K!41E/e/(dt9ZYljQE8g#0e6C hVׄ=H9qa5;8VJJ!T*itr\[Õ0b,ŮlD(mIeM˩Ҥ6ĝե]>8$G\aᎳgE) 9l:J{c8e{:[&FONYOOdg_ ۀ-WL%gTe#Wbo;A;vC~N찱fݢC2\;$NQ.Qg̃Z_z9f#(gD`=gTc乤T;&V$F!l,,倱 VPU+Ӆkգ-1F&0Gĕћ$i%'cnpsdm}ZlA7Yvғ\Tk7Ȟs!edXl$0ŅE`GABaKb+h@E";dFZDAVncsUQQȩmCX@fم(MLAm;lqYpKL1SXf $jp%Y8*FXhXȑ&R\TxX)%YǕjU̩3:4NJX]{"ױ; ~ *lvQ׻ߥcKǛ8b:w yS e`2A`Y1`z`|Gvddfrm2)ZdLř["|~& q/df٥)F%]C.E#_6P-^iTm(T|Gv{&8edh6:RVFE}#&]@ppѷ"YRP2#X#jH@FI[{dYdVyqZ2,-`D`Y$VI1c̘{9Wf+i0XሰL1( 1&uZX93V,Y q 4^uu {o$ڞњa[1W]:qÛsm1#_ǹY<&D\XWб]-F< 8\a1+N4r7y)۲T\VGL0BY$5 Ջ(DܣQ-\5S:fEoGI1՛Eᷤe|S?LkZW PE!̩rC+L^X}9iմS;YpI?璗&e[}EgאnrAWMTV~ 3"o(y(qj?Ʃ%-E0[,3%`MlQ &56:<㓶Ph7i"F욻^EG+bʲ83 CeUc(Y X+jR+l=XC};mPH;v/V:)rˑ\ʃ.QӠV4 .;>^~2bjJURJ2y'hc uLf,iqNzyzE8\s:Egsd*)+C `\_Ʀ<{Jaڃˠθ!Z#'N@^+Tp5O]枘d:STHw*He|,Φ<#ZX$jV6+Gl׭{NK\.Ï'RR흨RuCX oGwMtAs%_w=U&L`XjYƊ[Z58DFb]sw(D^g"Öt\N.EdyL %iF-Fތ" FFvqSh`4MQ±PrُHו^c%PE87L顨g*U\ VXw uYy=P~wMtAFؾeu>gͯ'gY)L$DkaO E 7F\l5Fd&ҝs<2X,JW qMLldwtgOTy=P~3fy73Q`|O̿k #c{c#:z63Q`njٞj6>_Ŏ/팎6;o3l5F3fy7:~?8?|?=IEZO ?3qXO:Ξ?cl2\j' z'ݽ_*Y._.E}5إw[L{ܰ-kjĘGcY fM&w~M@\ɦcnnzȲR$ڐb|i,59zWH+'i\xX/%Aqiت7W)HQ&yOw$ ڿ@AA}7m'%\mp1-?m {%Iic%[f{)Cm71*$>x͙ް_cjzrS_UX7*l_g/JJ#!:m(bI Fؽ(2t/6A[RAmc{¨(&/bm~>d`Dm;lMqfSh;W!E'B@#=]Ɗɯɱ Xoz>0Pܷ\"6PWQ,#̵k_Yp\VX&TLLb½B݈*:,dGΎpE[?eSucs믡ZǛ%,Q|"+#0CX=SgdSpqU4@KB@0QbwS*BѴnnVk* ؙ[ƭHn%55H6+_HP tjiw/}_WO!&4"iC؆ 4"!Qx=D52UV+h.wsƝT~]^=uX+dpbcm,"UrGpi42#B2+RQkS#;@t*R%; 6YʴHW<{8rVeTRVSE1 DKf*H[u`XU>Eē%<+3U .@6睮#K^I0_ٙm%䉎ܕpqV4+xu9qy6YnRcH63L[|=Y2e9εka&@[G54sLR6Lp1 =9^d ẾԼrm;v^%So@ض>/eL-$c-%8}3N2(Nl!ޚrm iv72!fFl{l1r(1|3 {&AuSF,UU՘dL&>iQi@#iQOҢWG`<$ŽϘ@T98FG3U5?6tpDk$șmUPFO"YFu)q~琕f厞N&u9ecb "+ѨE.2qkS?<㓶e9Y,_ a2FB5+ȯRKEG58|~C?yGLK "4r5nrtmI[EY%6a*]JTiYvcnVI]%VFRS[ 0"Z$HAbR!rȔӽ~h9C\3aϗex嗀KzL@Eea0]4nt,$]f`P*;c5pq< 1c5!B!dWI 10 ˨Tqfe^2T 8d=ĸ,i9zg̓ndP1F!'3O?&nGWƟbxή+5Zh201YRQ:j `kD܈1)y ݅C5\lF\r׺ƞPŕSYyNy쵑&^=M2uFE &˚cY ]I}4l=]\9x]h(FKm0}qH7^>36 ;WԬ[!⥍sqfʮ;%,+7z Y4љ$`M4c+b;ظLL<O4RGhef טܢYE5f?UR?Io }/V3LgɨJL@#{\+7+Uxqb/(n&|C|Zye_{-n=ўG:% 0dlnuRϝỲiP$?zu?I޶Qku~_xʿK/Mz>EsQwdӯH~4~l*,sku~_]oX="9MỲiP$?zu?I޶Qku~_xʿK/.7,~{&hyȜCU돟rsq޽Nz!ɥ{5fVpR e+?oO^YWeݻXvx>GXoi|o߆ɧ_=Ce5#(̸_r]h7 :S%;֙k X?}?[,dC]rPPPi>κM m kHg$J`6" IJv#fY7.t_\&H2EqD/v6UY`1tKk̹>cX'tѲ-yfTcEcQ+kYg2daSUk-Qmeu#ԽyBdA< XRؾzV5Q6 ϡrl)vfL00:XQx5#o`R3QA7^$m=dErF9` |3^ 2_-,X3Q$(*" BO@/Ԣ9@$sb: [ 4~m۝Ťx)M>]HD S-%o -(׊Z63XwM[,h?8):d,Kuj*΋̀9#\TJ8Md@ǭ)]yE:$1 dʚ,1'% En:"W-i:l\`EZX`lb[$(+4tfČ[-5a+8BIbaXZXAI %bG*$U-J`hw[Ffֳ5wANUơR-l G=E9TnNa.ѴZp.SYR-=9rz] Rͨ3UwAnd.%w\_"'Ukj&Vka~݉VmơiF \͸lg5d 5%QxhmGx$.豖a1XYM&QNj(м;Z'?T6yiQ+'}keUak|IĊZȱkcKo^YWeЫ`E~XhT!$a'x ([v{;]:i6߭*mGd:LM1ߑ5 Gyn [cl2jq# IDm\4~mO0\ِE y8&vYtٳFmc%>(hY#+j(/^YWeɭ]5@W$+ǤsmRF;MQ"^~0e.n  4~mQGTip B[ϓghJsS̺c2V†3 %x3ŭזUY~Qƴ4=qc%њ%%l.Z շyȼXذHu]5*b/z H[9TpTZI9]4T.GU*\E'@ط0)]Ñ+ƞV.G GO~r7 #&l3Hx-{5cjqH`ax)WBڞ+ybOjgKq,`_bZE0*? >.pН d4dqj(e==RG |sG+L*9U5Qш^cG`2ngR<6CvtnWd[ N mxͶl8ȱKš}{Ȱ$)Mgj#JTqQ<NۿY&-;2"j\vPHrqfBϑCCmG@ע%SLĬy v-ؾsڋ 47lԂLC$z ͹$+p#04GqW}A6O$sVdk(8QmK$k)jJRd$rUȴt*_«W1E D; Ni8oqO2NT| /{P6hP+!p.G]F:5Hu2:_v\|4hh γj$NSS”vsK%d2 ŢkR@Mۥ^K1wK1w`%gH"]V|ԏB/}&Ků.QO%Rw%R0wz}y+>jGzM7Iۃ( ~;~;YR=c5#Ћv=&K˔~G|C|?T|?TL_kJϚEM}e?B!gy#cTG |#\GeD_K1wZ>GZ5R8|8ܿonV|ԏB/۾Ma:2D&S؁u{1%Rɵ/ K$|h&U%9YQ 8)]L';iVjJϚE&U31ɓU[d I>lDm`LyEbEEec:$~{ %SC˚- JHW2H(j0A&t*1uB )Zk8" ܛ Gr_9 {mep L6F7( qɶPWLG \h^CHcd[.V|ԏB/)&tjeUV챺Y :8ady59_=1Y2Z27ծgelݓH3W"!%ydcu[؝bRoQ5:Df@63JVʅQ ZѨ⼢vs;U#4%b &"cx`M&Qa "8%V=k1x={j+ibkX ACZ@$8'"qd!cɯD QĤʫN~/6t㨨6}|ju u\ːEP qVfYTSʠ`f<`5 SJ6WM2(43IrBSr*i!tɓA#@)FEHhBk1]}ƥ jak lR1ƪqVHLIPioi *mK1wr̞<u6pk[4|"dyvZ<@#`6[IrV5#ЋvEuv_,X 2ڍk[ q[7 CTċ孶v)nn~C|?TS\t_T.XHvbsU4+&m#^e`,t5#Ћvqfk'~pD|jd aJL~\ڞH!w`(1 #-4'6Pzme"rdF9G'~,xSqSm`ׅM޼P;3I5L hͨyNI3Ό/ )$_atdi%S<3 GV_ ! " 9556딬'Tӎb(|;QC+IƳ%[XefMHNlWG@GqDETUÑ6R J}R3 9d5P: 8IJI`;.l6AX[ Ckw䣰,k4hcϙxD~?'ŷC?yGC`kLFTT'#:褪"GZ|*1c\络^Q1kQdn{CȘ(`LM'ʶL*e M=;jJrCȲqy_xΫYi%܍- ( yK$dRUM׮dѡJIVLkǑ_K[,ԮiqX-6L j$"9cKY#%b *դey E.O:^LJGc^rʒw h [wT^XOBoemm'?v ?#\o j/_o^ [XvwU+?xӱy4Dn #J~9gHuE-HL~-&M%e^;9ML m{XiCdb*=Ɔ!sZ]ciVMNg61f<ǵ^Ig[3X1*ogaQ8vrMsuVwD,-;8o8aqOWݴ7̉X I֑%:' Ab}'r4$ %t*VخXj2' *!N i˒(EVȲF("z)͖p.S%VXZ뚳(d  3ڼ68CgRtV ױUq˽%+4=(&4m+eUR9g@WI[>mlMԀ6]yQya= }qiM(<1PWX%tKV_9ٱf0enf~m-karQTV:Vve2-YA| qJW^%M$+CC%;;p u;8Hi +5FL-kQ 0K~iXI҈H)&d2dXF" ɆBe`rh /N˱_.=<'-5m>' tpRFu~0 eMN¯a,D`΂5G42:NqӨ:5ȰM1GkDp,{fujz~>ƎzdŌ0{<GBfZ\Pqϕiv@kxtl ۹v&UIlϤ29E$Z9m,PM}9" i^W|Q^~ [Y85L(˜eŌ2TsC#wr3tQDiR%V2d9`mkŎ`!j(@gl{Q**縌MV-`I4đ :/oo,-uYB^`G٤,EvJ+Ukv$,+\ǝ5s,q2Ҳɠ{bWIf;kRTfl$>FE2Gޫ|?ղs-$|g!l3n{7au0o/,'o>cRnkoD#ylj}A>A1%k%{X`}vM?ھGaf0}U"+jCfJ}d $ru {"" Ư=[JIJL <#R5\g'KaX'ʶ@*cFa'ey>+n>NYl4u=~,٪{^N"iG7 AQ] ú@H:QY Ŕsֽ*<>5Ϧjx) =7T%+52Z ITYL!ZW,q>T#1$cS'>ǂN>vٞ_UEeM\BiVG!\:o`ڊX9UY,uc SYCwj x/e|Um`cYB4tv##QU&DOxpHʴ$ u7dӻϯ׆jݵ q,#Kos C799NjrN>N"|ys{?iQc-Dž&;6u/yA,ѩ|6$L=,#8NDnZc}8È*BfMt7 x:rʻ7gq;T}L#bc]Y\+vuQhcT.1QS;EiƓP`J# #͖2W2ڑPE?<^NCI٘+9Ɯr{zdrdB#D\x+KXP4Nuy~=}>]?o] ɪFghu^8tmbd\T|qETT7}A(ИH>s\ߑZ*"q^ U.5 1-v3o ʌ"x*O8h#x"x|A9$RCē ms06^}|SqmBЎ'MQ‚{93Z<>%{U.0GaOdǕE:ʕ{X5,]}ᓢo"8T_'M5B=j=$WsJ4Gxs#$zLlj\3|eB@QBH?m߱}QE+va<*5(H; \Zfl+ :ŷ8Byo\JX,Jq§x|tb={UUUEĦs'`p ƭV5ʊn5x*Ov?$l>_Odm6{oq`-1P1o_{R6Pfr'0E8$ɉe) vF{ ND9[:J̹?o]Dz8dn n^I/UGqiT^*r𗏣1%nyEX@eZ4">g;5*kF9oݦ-mcv'շ÷{zjM`뻞;s酔+IZV%q[Ee{TKU͎t;ъ-zA(գ\@O Ɨ&OY:$ӥ 0+H&G?: \is=l9hKVx&9hZy0GGj:G+HH{ 0k0Q-koVG/hbpi#&k$!0#,ڬ ְۍղa:J/R<)F=QǪmf o]t'u!ʲe{ 3t%0iM FطWloD.t"Ȓm~9mIIMF.>3Y&7͖yPY#:5S:Cd"h-"-jpJ"C4htWD+qQ]컨 3:< L(uZX5 1 񳗖K ǽDic:z,]3vb y$M.yR"eɉz*~g+>56k d֝wQc]+kiϲ, I'+ZjZ.MZeX̴Ά9XHV /ߴ<)]x+mDӴOR,XWXI-eu)xԈSC 5a:G9Z56t4cKnQ`3Ȑ&9)+"D;1ϓ&A&({΄sPyf>Ļ`NU$ю"j RRkOYv>2eb]nPfVe|+RF,s^BTD{L4Zʌ&=s5R+,&&6:K$<%dLl|z`FT*9W(XQBu3r8`48r&D!q/5FTF56vճAe]C0,bƳ|=9dxwQC A׊4uUb6 UT{4hY1I1$7[Y'B@ev!#1E^Ē0Q~O~p˱-1e\Vl\T~!b@Zd3,X sM:5dqwY!(!QeViv)n2j%Pŗ"T(kNz["\9.vfChP:%p P LYVHؤ 0J'1$1=},?b|RVN$Və Y K#.d‰FQY^#x~dNAiضvP .rcLZM8hi!j u>!,}qZ,$uԌf-%$WF7GPr.6OWòfu{&6@<]8 &>1ȃ[MdөncD =k+B4aeWUZE:ߦkvFn)#bLBviwE%k Z.xBF%F6"2w$4c\:= A̱,Gogj~-`(2",dm2CPLmfcԓSZ 3Z bڑ AFAL HpCZbѝ"b_d+a \ɀİG9qd@ lzVV.iF5Y:qhOhyF@N_ńv aGE*hb, CDM;Ϯq22g㯨u"Kb;K*U&S/i[1LqA,hUgWgm5c /QUUQmrm(d.B,A5 h$I"ܜJ Y۾:Y.|YY>jJ,ڧX;o8v5Vh%v;EϚ?;l65o8v5Vh%v;EϚ?;l65o8v5Vh%vY*vj+S&}Wr܍\8zkX|). ¹qm" ^`UnH iaH$n$w- Zw\ybt {sFl:twGlEcj+R>[9ʍ<eNWDHqɐc8I3,b~ygUC$g3ձ-mKHb:vOi!džukNF" %IQ#y^\;>4t/[ C=vsoso|>;\/$;\/$669}#{N OcOccc'7;\/$;\/$669}#{N <,2dF"@ gF X(/rJQ3G?,3O{pOpXxc6GtVulc KdDp{9NeH}~7~66m\@?Z}[~7~66O&/_>w[8: niltKG݃[8: niltKG݃[8: niltKG݃[8: niltKG݃[8: niltKG݃[8: niltKG݃[8: nimFllvG݀O׏images/schemes/rainy.jpg0100644000076400010020000006201107432602224014100 0ustar alexcvsJFIF,,CC"  \  !TU"1QVd#2W $%'347ACva&BDRSbeq56XcrtO!1"AQaRq#2b$3BSTUVcd%CD&4 ?s,a&7Vb@X l(b"E !32bTHFnעF7}۶MQeE.?Y:)K`x=R3J=H'LVe@`v4R'XBEM[(UҢG"msnōTXqbXexe6 2>[$yy0cr z1[t5Ca~g^m~w/~Vqfc_|, N_ ٮm@b $)^u[KT eIWƲTI8LfhWMbS(2:7*Eaj99_Ħ fmeF),v^jٖh5tb4#oTb>϶;cx>ΘTkSAA0&ɞ\~Q*1Rnk.SJ%XYi׸/WRV ->mv01$lgg!AKkԣPe5Vj;s}Zmv鱬 $ c*# pEd ;d(\\Bxk.YGF7Ke*Tqv,Li2/EȆ+e@q8(KCB񫐠 4 &߸eY:I$H쪤lnIQ}<]0oJ8!DG%O|\̣dGQG2TXh0Ʉ-EMxE&H}6cREH$ TG.1I-ԍMknmc\7Y䉦pH\*ܶĻCWx(`C>FU$fh;12渑L 1/ekxczm=TT ˌ9b ČltI9tX`c3e`RB*,Yv v˕fZzI!UeCJ٘ \A;m.wPU}.7ϥgI,"Ւ\ ݌ikEi":V\GP  yQŨOGr\Ux&"Cx]J"ˋ M.$myPV5UI"7V m~Fk^C. 4+|Hsc,xWRfxb DYop-~Wsyc}^`a˓nNi"/*q9)O8mLzK {\o:Qbc 2$ΐ3dǗBH,8jk+tN-5K=T[g"a|]:̏#AZ%)6?9ԲI!v ~q Hu4zƏ>YA;DtCg&ɠڋgvKi{[D‘#(!T^Zg/#Q tL.]8sêrJ"Z3QV[l\k"Tj4Ttũcxɜ9L;K:jfePH{!$87UtL(5bui-a*̼)Dֱ%jӫO;jۿY/cju/ZӶsofr,"&isA)SDKBVF{"^j9Fj}I*%IXX,RvˆHa9Q!YK`7([61 dG9׮GElgd46}[g /l:h"g@ѹ"9?H4#^+׾{.m{\cm[j!*c1;c6X#? :ˇ`@V&!Vr j;ǂ.\m)?_&-ceof?22ͯVOd.F r"Uj!e6V*k{la-_j(la)u=QZ XݡC:d`DNEsGȋ$w#EX1/#ٽOD?tF6TMκ*Rg5`pKwS!mZd*h!ta[!"ǖfoEXY3#քtR@aɅȸؑzZzy<&dW(of6$oqnF$ʩ0 ɿ]ݔlp[C E:D9K=j$q$QROR +-ސ o {J>T!U,Z#~v\V;:Dɤ'dl:ən $2B`c k)v]1#Z$pQDž=%ΨNԪG3բ5M͛\m=O W] ]@uEZRզu]5MHdh룈F-kio}釾G^m$"خA6+Ɓq^#G+T䟺g{JWZ_O-]j$\`)"l)حAO"{aUZ?iԱd:~V\,=BةZӡ{xƩ^c=k?F|)Bȭ"UYs2yr`!6ͦ2+ڪkx-̎ ӆR=m-L,x9UK@K^>5 x 7:@9Yx?-쳷~[0]@~G }e|sW>x:_cewـ>;~ 'ﭴ~Ή?xW_}m㟃zi5ߔ"Eף,vYx?-~Ή?xW_}mtIbmkO^>/go`?߈;lgmutIbm3O#[h^|?{t9Q9q;TTp'}v HNY>1#1U(Ǒb3nۓt fwP 6mLö[oG޼eGR#o*^+R_H:-Sʍ2efKȣI#G#_vrlJǁŏu\n\vm5e~GU1B~;~ :qnoC̰[$>D; /u4dM#@sΤ{WtIbmFP[~öaBlb*hG<} 0F۠b WBr3za_ 7FSJ؝Z"XZo|$pZR @oiq\; ʶ+eKغDa^ CdrccGtһȮU w}W,v%6äii*w{2I sNX`)P6^YC4B{>Q7m ei!4Hc-3?,`2a1&%bŚ8CӨzyյ-kvC{uhGt쳷~[0Ggo`?+z'ƤKC2c/LNK(R&Vd2Vv1G2ρ 蘬ba&X#|k#b;#UDOy2[ ՟DwU{Ͽ(/F*co\G}.o=YdȕS%5q9Eo9́]m>XYm82wk0zrc#oeˣE"uE길&ʎL.5EV;k\V.#ZJQXtV[1U+>lEUM^VFEOXFm %XGV7ԮUsnb2;;7j~3UQ<*]aK{I(`lZ6# f̵5fdmZgZPLd# zIj+bqTV/Y}TN([oJ1:Ld8Y07$d3O3 n δ|tX^+C|/!% I l01㰚NZQ7I Հm46l]^huEhO:=Z6$uz Uo$|h7fDlIRG[:@yt+Xqĸ#Gն`n=n9yGiaبgM,$5tFwz |臊 ۙLi"0]{)D0P|/;yu!VG$fWG!fBWB8pcZ"pO3θv# iAK[؈S$=*Lů(chAw/`(p{IY%+S=to/zߥ{m`_Gz?WUX/zߥ,_ELѿKY^/j_K^/^q jIQl(!sK}`NkZ$=5lv iC.>㒬XV\ō/." Id XVQ4Uax4eQt=l>s)I,M ],;"8E):gI0[VFN6XIKbcFz7vӢm MsJ5Eyɳ߭xaIqgk&cKW*KGՕLRF`4C" [`=ɂQQ 91^2 G1{^+UMUi6'ta|&ڹfʅ7m˘k<Ru1vlEp FG#=^j|g8msCXbUrJEN1Ո:?*!V%}-!ݠǃ47%F̴,1U{ 0hZ{A/zߥl|ѯ/c.3!y^ ݩpk1v:ѥsG).k^y~AS>wv݌7,^WL7X!fd\9,h'ս1,!A% ɮ`64.x/ڎW ~EewIYhh.g[d tL~U8\K!}l: 5c]aYDYLPBXGAA\m XL!$aPXs_{z36o|h6eHJ 5TJǻ^ 6KH>c+&|q8u,xhnjk؞Bd*C>ƿ =b_Ug &n EmiTgy amCb 3S[ְp:/lMIcV_j+Jȯ(R 1UsZף l |cщd<)v5,ŵ`3!ṘV+Fl/cVc_HZ|N *4҄bBF>9#=ʯ2*b{ax+6 ^;5\<5F {X5lCJ>MIwR iAnNYֹDgŹHX5m0Rɮc;X`Y-EB=yw[cK JʸG0R{*&,&euaIiH~J+J}m[XԌ`b$AE#YłY r[I8)qK˥cuuM:sѬ$zDG1 iUuE 擭lT"r)a`YΥk( F;8()ϒbttܘm(qXiۭrn;kԾߣW}J|[b+ILHlia\5KE#s B h13|?jQ/۵O ttU $@"i>S VUGO0zi pfzwj_oԾ߬OگKy_êO=Be=;5/zwj_o'^mW%vگK?>{zwj_oԾ߬OگKy_5R~}X?< ?K"ʜeSyxO$5Ծ߭Lzs,NNH_Y~y_rS۷O >X Ϳ?`_Ӿ.R~ )'~E<8S b#TVz0hƆՆ@yci˻JC|_}g+r𜂵qVHm&Y+1Y,EpFgF7y|^Xy(\I^FDcN{0Uyay8pw?yGqE )wUg3UQ0bRG )f#aE|PEd8Pq1qocnutؤ=hg/T$W_΂I\\LZCjSl* ^ ȔYű|izi(syY^<9cEfT)[dB2QXM !џ.sXB^KvU+0/I,%u4=V4%j'`Dw A0m&?[\VFcI3+1qG_֌oq4жʖ;I,y;Ea 5\D#}`)K9fK-c b4'%0~EOz< ~/a'%0|KOz;_9?1 /bo/19{/sORqY4M`b' ?~{_9?[iOqu|D틸~ ?f P| gޱ\Ĩe{#nvW|ҭ#^Y- zz.~EINeKN}H4j%[v@&!^²yc`X(j#VFnƯkt|zJ;G,aB)Z7#jr q Y&c;`X!VifGYV9 <(UاN`rm g8(!8|qL;iU7S;zc00ϲ{!ÑJt'=[f0ЊœI4`_f'.KmmŽ m;.:m:2멶vtQ6Üd,knXfsRȎ(sc ^BgZeؤNu`ԯǃy<מ' Adӑa3$Pe dݲڼqWAb(ּ_5Ⱦrc hX ذ;ۑ68u~*rDy3HV׳Bm{Zcvy~WBvq! v K]wGz2:()(Y +H^CDFٲ;|TKpfuߌMn,LntA,dΛ&neń&WTjбP"w5ȾrcS,HVjSk$_7#lD|RhVl7 aܮ+u[ d9JpK٬`YRWYES˵&?"B$9K;< 73LKBLV3[ ܯ U>K L3=(t.29KS}J$9I6;yI8AWu pk'ڂH65 "$*"$0:v݇+GjW &g17ɒ̕ήs$5#Fsb0O`YXrG^nUj),qlg{}6uuttD}ω*]J#Vf ]S:=bt=QrWc3cZK3KFDZ]d9QNSrD{c*цHibapD\&$tfO7SIó CkX|0ҶsN.[o+0:|; Va74%vHw$Ȏ*sub^k P`U!j)`:'6tVzp>FҌ J2is)ŨF@ :'U #b ^,Ot 4;_`l]r6?T6I^McJGKkXuTP8m"{k_Ē,;BĠw#1"aUZkY7(xUCy_eh9Ԩ*ޯTR{W۷۪(LlGmf.Nk"UE{$"qA=5=8s &IxmTnG7ɕ k1͞)*rٮ9n.1޲4Y;_+=Muao-U:_lx}qwxaK޲4Y;_+=Muao-U::_lx>8UG<0Y~M/Oɦ׌:0UXQ ?/<dG]RM?V{& dkG[txè U_N#UQO '$ZHޭyDOzgi/pj\8ANYr*#Hg:0UX0O? (N"?du*ߤ—ei5(`=ÒZޥ̨,]嚽†I9trX?uaops ! &"\ҖVC]MTG᱑j|5`s#,G1kBjwxo'qTwxbf{\f#l$j4j$Iu^xY% 9Ȏ 0Ts׋#6efyqm^&ځkcZ` SU5]LŸ|r?:;'ljg8M,kT1Bu-C'ڬM"]H-֦a<:6;Z^1ǜ{zy6"C(Za0a$?[U[Xo6=ȳc+.9)16Y~M% s8[xܞFV; b.l9E([cT֔adW; &c ? G[t̓;8>2: YU O9I)YkjA25}̪F_ c%Zw[m{]S|BJn/UQ>S\ f'AFגr<;hGgc3f@!)xQ7J)dXy:`,q_~Xfj?-e296CtX(\(!C1#ּcl1r+ȜX8ڪAe;~~0#m<%Y/Z=펕bSwx7\)- T .QŧvtnK-!>"uI 0U Jj(-M:g!4$Ȋt4dH/WNdŔfiABte,Fe }&߸y3?'kWa͋Nd*]T+`v..VI, WʜQʉoe=w'ASGcɣ+ Q\޹3ZW9^ uUHK[}}^c,5IjfI]r g,X\c!QV⧸\L5yshsщ[Le|h Ox";3)xA|h!|Vnk.(kVUBJ*LմF3z9^wy8]31$bQ+mRmһK|r$w2i_09\_0g## +[:ǷJq;.61c=Tk sD"y" k`J_XTRDoIy۩YDuWa o${Qb~ \kPlV9vVLҨd̆kwXb~Gb~PN]$]$bǙ'~.zZw.zZwA;v4;v4: 3N]DSZ<]DSZw-i'4w-i'4u?ٌg8iަ'xiަ'[EOh[EOh~".ɫ庳lwĬ$2#.)bEH fw)ndâ$d6 "TXJD>[;G*d {Go ْmf LgRȮcR G 0ƪfOb~U8XgIO8Bشe\1!דBX댅&c(^"sխzL d,mAA!ơ^1;F5'2UTEDU^tM˿v YnN{ZmnVfDIxU=:Թ$:Uƞ"`;'zX:L63nea+2CeLIhΆd'ՉI1954[EOi*\ލs{|<19~Dw_| +>+H}XD =,yC2_}4ԬdCf[WYd sHH+a;KTɭZ6kTh,p$VB }ֵ$YG,y(ɚPemVtLSI kL5}ދzwQqs`d.(s׏5j{(#-㣭zw Nֵ@Ymn S1K̅Nq]-cȁlI2;dJKXHZ4srcwH~jGUy"2w#& /;S:#y,qM2 oG2:9QVrfT9lQKM|!02Z}ת%E+B6W$S5ߨVw{2 qS$JY0&P Q3r+z'^o53wV`,"]bKIAH$<#S*q}_S[KFb;b7M )e6!wXƏkXwҤhS%U8[Tkm{Dovdj=MBO[c%]qya-e%̣ezl799"VrJ'V"G5A˙3I^ bCpWdq>.E϶IX"Pc J(B2;duw$9D~oZ[mNVMQ\~Rw=FK@cLof-f8ΡbѴw=aN${v`l~KM*G+Nk%\)m sB5Gn #\xːR#*FtϋU\Zu UeW/rZQVinP[Xk%tCn_V-{N'~1,=}1,=}B"+L]FbKl b轹7Xqt':O._y Fa??%3Ty:c#'_y\J}{4q.{|KÃKBǷ=8xİT?xİT? O`u+0EfdklJǎ5[Hఘ|A1qCo=Z+;Ҹ_W}y{=xK)Xj,98K2Ti"yuPxg>EZ >`Bt,, c'Sw!XN(E8ʱΒqci y$h6kPm=ܥg ѵ@WN`b.@Zr=P8%ěm8xİT?t*뭗/Q2GF/x{B©#וkCE8 ]'H \^U*5QI$ O 'm}?G)徛a~p' Ių( AiX1%.ck' MsG~lT:1ZHWK7[v0m ^l~* bVK]"R<&ΐ!JQ,212B.2Rʇ(RJe42#?rW.jZc^-)Ug«u/# mSb "#b/$}{WPxgbwjϺ-NU VUsg0MjU!NVQ1ydǐ6;ރTߤgxc9LFx%Ej4# 3KZY ZhfiLs^ er1ёp-*ۗZ5\(uFK Bn$W#b(r:8Vd`*(7#td Sx> yF!eY\^x*x/ /ʝD;/T{ʜ?{4t񱿀놹p}g!lBȖ3YQBnqqA36Q)㘑˘ kɽqspG p+@D4yq*WʪyҸ|ރTߤgAZ:P{OS·`ǸU`̭:nAnËG>ߤ%iX(]%48a:Akd7W%Ϩl1CL&cCc9 +\cx+/*We׋\V8X^d~R QWGIdnYU1x૩y1"lOj a>ÕPf7k6iv7%c*R䏋-TZɻ|D,agXsl\eFK8 B {ZȄsH)c5QVؽ<ryElX[92?h6Ua2aD4r B qߵ=U}xchDjb5/.j`: *3X'rt:{xr8O}vjةxTJi57sl $S]SvshۗM% #P"B`Pb;%r9*c`8d1<68t*kTG9~)<&c*! "yb|66cFs9kQ8}t& d}sL4z\L1+H Ř\f*@FŽcqOɤ^ R=tDw^xpFgI c1Bk`% "DQXAo:+ע****qi͏YygdT&Z)6,K _iCUR[= ̯2< ̆UWD2.g=htJt"}D+юbB^f %Yg !OiXmid8Lw#9ڭl*;Y֌f1pon"j"r[Âkȳl& ZVib]@*,zxn:|n(S)r B֒TpzKJ,4 \o]ZF iA;X zx^b=g#܌~إl\nҶE|Cd;S"@:3%{R9fVcuxGM|*w44S)G:+#&n$NE29'Uz#W?L! n=\i2 Qa*(={i#j . nvcm'W2[!k}][ac/hԉ\7=%zFMcIRECgP&a2|(Q{CmHX,b}dž&'cfKwr8{Gx5}|44Uz|> E7*`[yı$N*bmωw} 7gGh訟H ^k}_cNTOl:ѣW:;DED@oβhG1;DED@oΒb jqǸ2&Mr}itc-GRrYB0r\8iR$a{m~i'E-/sl<Ԡx,'k\J40ZYǗrd軱vWNn\)H29ʊy}r]p$Vp/kV7F~uVfnS4OgFIbiFXn~|5k̞@Xփ0lz$l-^;cUYXL1U`UQ^ UGR9[=SIr?^ mV+(:& k cŝJ)N,'c.fbED9!C1ja OW(j\1UDUo^Q?l MHٍě=~Tz+o~IjM5cBy1kBy1<:.A;0Sb5J]|ϣFJJG%Ճx=G)u{>,; x=G)u{>,; x=G)u{>,; x=Q=} [4xU7hѨОh 8G5^qac{&4'=G`&,=lodMWXzɣF `<< [4xU7hѣBy0hO4{jMyŇ4hОh 8G5^qac{&4'=G`&,=lodMWXzɣF `<< [4xU7hѣBy0hO4{jMlYU|#[>KF.zp*%himages/schemes/rose.jpg0100644000076400010020000006244207432602224013736 0ustar alexcvsJFIF,,CC" S !TU"1SV#4W$2AQt 3q%&Ra6BCrP   !1A"Qa#b2BRTqr$%USVd345CEs ?71:cgB%Ye6ñyAI)6׍TkrS0֮ /PrXińqA>W ƍҎJdcX4E{2#; xVc3R%X̊l r$4Q1?ΫcB,C&=JM$'xdQ\B6Dq:&ǫ7Sj=S m?a> 4sM&ue}gH>{+B@Y-S5,Ǝi64(Eb?2G2P\R1hBTREX1.:MqRAқ&"5a&5bc [ӘV 6]^ Һ/R-kp݈'X|iwU#vnGbTp:ٱ C'W6T'IlAoD\n[i2J! 89~sz6Q/+f\W+aHSj9ˎþ5pGGpse˫]rҼkp.Eyaeɪ`]se\-H{z|Z}QDf`18__HΓC$uc/NlE9 գxI=ݔ8 *K-3|@Nzo()t!3hO2 CIrQ%yZ + !Z"l]x=$1H"ld>^$zI,1ҧn \b C'W6rb[wܸ[+'U~z."TWBFdqHD0"E^1DU9%c\ 4цśz-fc|܅cFv TAf˫ifx[]\7|0Te/xAZP7]ş/NmAiO]u+I(fq=jcώ۩`]u]1m~OIr,v %hh2SFIz;")K]ʨͅ.hݔf!d듬t~9tr"EK J& 9р-9Fh>E%/× FVߐ< G'p.Ba% .BK':B16w޶ Pgon1'iToTGbښg67gO+2:¦RW X#cUEO019YOEb~lɛ Qǹ'4^dGe[A-mZB5W18eٽe|FtbGyNѦ]^,kI#&̠8X.e)xAvnG˞_ )qWJ~.v++,D;:&8BFy0ÏAI¡)1Ɍ_tv-FCX.UdR&YtɊLYYxAF(T$\'#mǘg"d4~}[@~c?*iO\j$ҩC谪عppv1卧,J M(4Wh=U\kNetu-k1:X12ǔ$b|  F*e3vr$KHip#j5EqudUMO*jb$V>A*?.WSdωFH2Kd'Fж0IAeQrSe򜮓r\*|׫iDˁ(] Xu:!(ZMн&KjP4́%{k21P%V1einmhܒDaW-]3QY:CzxLj&up.'j-f$ve_F*T f/hb+5ڂ*]&]"5k*H5^ڱ&5MpD.<4,s|i "ɐ2lX.UXƤe`:.ό^yѪ&= c^vYcXK oE/)VeJLQV̠/ QċQapՎFɱyuYlMm\NjXJa2-dhEj8sZdb9Cs즂 ¤C*AYIU-]hiX3ΨNKtI9riYUG*=i7`ao2SG/[|e~s^'kaO5I0u'mycw}iwdᏞ_|e~s^>Om7O$ԟ'kaO,m}x^.~̞ڼ1Ҳ;(XeÈI˧0IZK/ 2b\zZ^:VιȴVkkN9zp)kBd#_f/r[p^o\,bJEʑqs=FVMG 772+3~Xgӣ=ZǙ6H98&s\EET*oMQm/[EȰ46"H]v{rͯ2SG/[X1nuv9YK'zǧESI7Gֶ8wx˻r߹?_R|f74ZdIFebcJﳉ dq^r!Oi#RgT<0Nv׉^|Qy$$@6ؑ[qϥS8FV\ؓ\tٰ'Ǡǔ[wGtb2!9hߥWqkbʅ$gou:#ЂR;Vbr ZN9XtzФb ,h%2$AXʫ߭lfD@Zcq1hdQ+ޟ#Y+6f`Ӂ9GptkRK4vF:^PwI.P`H,, B+?T[Sg*as7;7ʌthq1W3C Mp Z1g+TY^I, T(Hw-\f۷6_#}xz>H:%nP KPZkFqQn`?#HrjR,a L?I+ItlFK&LzXȁ=aJbXEkH+Z(9fu54頦&݃R z c1b3M*\uKQ(>^tF lj]LɃY:^,וjsG*ő֑QkL-73鑟ikf:[4y^R6Jl144RW7{Z%tgD *C'ɏUe%\j80t$k{9R U{4FMtꚷXM:yIŰ}\Ō%\a6sn1)CBlGpHtSIt$0,fn{Y.m[ Ӟ+%>)zrLX_6O>߉oRgt@Ѿm'Ihg"J W:w [wbʼn㕓.vI> ⩉VBɁ %Vn\Hг+΍M"5dSNpcpJe0UbFx\HWpjF^@2 1JH-Jgcנc[ڒ(9IL`66( .<:J^fLu GcmW5ͳ):.)asGPJ9:9䮋#U2k),ldR(KE7^jCYnYM͉$ iM-VScղG}GIaYbcZFfk\=)am3YgD'X%%,/9&5+@TB(UkX.7v?^/Ճl >&:=v{g?w8ߤ|\o 768+\_s}>8IHEcї{@6v{f;&+d*Mˌg͎/\uwsM4~Q:U+wK?a1<,Re͜r0yp&kP(a?=ʯk\Ool>.7ڧ`UŌںK ;[:؞UHHu^($VGٲ~PzQ,rE%TL)VTbᅈY D1:M2lIxA,->RHU$ c5S$19' a[K')#s:ɰ2A(Hk$Isk A1NxT6Lj*}x/={"Xד Yh!&GtZ-u[:%eތk(E~]Ա`gTy0ie]&d`$L3xf@dpZwZRfh)4UT D.XQbIz;=0fIR /$2!Ml ,YPK3u"ez04>Pw+H&vD8m>WǁXfocOSeJ$h$.^5+ޓTj.Ѣ@c.)˦54J:Ɩ$" QbӅruE5l8][Jd>\мibW,w4Rq1 @NZdgig_ 0'D*R]ƫ!JDFEW z]i^|b6-M:"KǗs/,[$+G#{|ZU8_ќɹ'e- \%jN<|3^bn*8#Ć/q26:scm`lBV$ IJJA-Y爫+LQ*;ug&>a$ڏ(,=`z9,0IٜS G2$ؑŘQ=Mj|2'͵6vy\>Al`ߦ8H*[X9#.B(ѸC&LX>>}$-;/)8 7zntzƒԋ5wob`h~f%:̧HB \7һ1 Zu6FX4L@MX{p]n.7Jt2XοY6얪.q* =bDƃWծ@wy.q&V:kkӌ TO2dyhO=v)+&Jl1D$RKMb:CGHt1(A+aOxm_s.Т B-o+YɊ(B e!+2̈w"#Q!_ɭvqbq+rε,V4vb +!׼dPrV_cp-*GDmw*[ #pJ'V7D 7qjk`2L$g]<ŭc7hW)ؑr;2=7˞e7+Av=48䭖c8aHƦɭ#f@}a~TAOL"4F=I6- >,jr:Wcx<}hk]GOdnD)`xBJU LU ?-.QKZ85jsf\a~/eÎ ] IB  &3Z@`2;edzo0N)Zgαq fr,hp2dso i1K٨7dz ʦoc]ю'4ӭT[G쵟%V:7W@qӰ7«32*pیTXRl("PHxqH1sZGIН侢gxݰq ̭|} ijgJGu`Gs2+vgiH#Ӫ{aXhF)(z)ʮb/MyWRۜحrȌh QMRH"JjgbNՌ(v ޕgw! E`e }Dϋ侢gxݨOK AA6a֭tW2991I.@d0ֽUsף>MۓJi:,6;My:$~^%>.wQv7!Zoy|,ﴶ; }Dϋ侢gxݧ;}g}nC ;-yGo$`ګFESl`)Ҫ|B %~=^ȭ/,hWDZkM:ܮzTd l 7#$7bmY϶Vs$pcЅ#;t3 d'CcY]yuu|bcJ<̩k  ϊh\cCvړaqK&|]GUK)8`jtU :D-* ߅gHo9rEYimMCE\-T6aYoDP&ˆkX $HWKi@75f5@ӱq)z&͇17͊fkvAlV1Y8 x+d2lk򡡙 !jfO!q$O)j:wc!uT>K ]$~IQaGԶC]e9l|=YJ)"XR-Bbv;"Vlm'+rk]jK2dh ˠnRbKt8@>asԍ{cyv!X-(s o,ȑf ##Z#0Y2șdiz4kնcsA#$4 T\ҡәc88,&abm]ꬹx1"+S_6ˁZ@Pq\ѱ\3^a4;Gm93VᮢΨf_je16N}e/!ƹwHBHk͝侢gxݲl DRke?K-AstHy32a,rCU\rSxƐPk=wy|,ﴶdX{lAQvF.t[2k$$<0L[A TdcԵZy728qAhrEYim&-2ir4[g $^7^X|3NxTR2;MWITFI8e]D Ԭ=F8y֎߉)K4|&H$X˭U# Tc[G1\ :so]aP&'n?Uʇ@D|!#G,+(GZE9l>|6SbSfƯO26d!, ;Xa:-؎_rGmu3c)NG ۉpPP[Y >⣮M[&ɷ3#'4c]S$) $jOę+xfK$|ȦC ,O*2[%.BqAo\)8G@olmAmH ňSHGiLJ50ǰqO%X|ę^-QgZ2[27|jܘӭMA5UAl~NMр 4fk#k9tE6ѥh2VI6 +skv- nWM^>2Fί YĨ(Zv])npё1N+V9ox0m ض A= tW+d%LBo*8(]$DEȥ=gx" XӪ:x]*T䰇W^CJflGyRDD=ų˛z*f,ZY0idLItVJƺX zȇ *H`=$/AHQY@F%i&PGX,۸-|K$9=X-KG[Eh3?m}{u>=X-KG[Eh3?m}{u>=X-KGĴzggZDwYu;usP?Mic sZvfWP_'s T׹|v aDwz;{wbA9 §ʦ !ݏI0r4v1ȳٔI| x#sCلQ \O/MM $; ~4F4wwd{ZGԐ@<6}4yk5}Etz6&cs-tizADJhyZzӘdWdwWVye.h|y}xG #p:4#',z>Qza]KkoJHǚ:[6**Wc:yiѨ{ +/u>gK9UX/di ЁښtJCZI "4zsG jl_. EN @0B*V54U*V|X#n,ԍ_ zs:%mG{]ޯ f $bQ6i.:VM#r7y<ιZKYWkVz7T6Z5ZCI|e+\*彜q5P_­7NH!.^&HԖdqϑ"ȇ;G_)퇚UZAƬYHhYxk"f78M[j;42 Lpc.OR9M}  Ё0Yr?uiږ #ؙ^k5LU85G=]GSTՐV+KX25ฉn>ʟi5Jf ڮU L⢚cYĆD `-=qfAg['vAP]ltc b,z.^,4xI6cgF!$-%q^B28㉏s[U<#>޼bT6X$%zNun2%M\a%Q #8m UM/$NÁ\ a5k\PdXꯋRƻ'1 j馱cRڬ G9%ہ ѡ 4|J<ŝ]c!\B)+Z!_$z!ɩjWJE "J~M$ @Xj=FP ynC~ѳ) h/}i;?cǽ*U\hwQ꫟bSL˾?}`{|NJwh/}i;?cǽ*U\hwQ꫟bSL˾?}f/g ZN'{qJW>w;TzخGckS2ﻏoY>xv֓;A{I\{ҨUϱ]zU+Z?̻ga(oTmE"/PUm ZN/S&5*tOSc5SJW>w;')?ܿp6g0ң/sϣowh/}i;?hL ˼+26 `ǰVAtFINg@߄^J3;ҨUϱ]ԝEԼrNx L Dțʪɴхa rlsEEqQQw"NRF:Au#Reߏ)zgfeՊ;1G p$RU0bH܏TE*hlbɪ I$g;9dl+P| ^c'ԧʺ} VFE#4ؐ< b sýЪ-&\V2E,NR9G/>=UsW}w+P#3=ç+ktr*chٖUP9Kc8d 1vW2Di`u$pT,o][YG,^\.O^*uA*P%|/4ڦ6S.ldlJV" ;yDX B%Wﶆz'J h%[Kmd*I]qݠ2:dI<ҾVs#e>56#^KV_1)HՓy<0~SK&H.AZFǝN6P^ '{HAN)NxBhEŶ'|jH"*dL/Ϋc @d ƣ+`Rwo.GD̋[w1qJ3NKU<)-Fo\q= 4AvXUU s+ɄnH#l܏<1JG*+>)[BXEKHm Lq6(WRU,K +|kdMS3r`@'! f캈UY_WX( eXn+4H4T2w;-7KUEȩ"XcKk_VFV%=i&TUa{-/)ݠ|Ԭj\XFdNԿ;*mx%Z,Hc"Bw+TzخGlRVh.9e؝%[j(zI$Ed^71MWIe~ny+wDr8Ɠ4u,=!p73_*QfUh\Wmn7*/B'Ix1( g]gQ1njG\ !.VY?%C{ ,X.(ʹ- Mb0rXExrV' [.e(i)N>C.- 8jG 7BRX#7«ܬtxcژQT Wpkb=3 rHhj+ZtfH ErC,k\I]%n_dj9:[˩ek҂9mٕxie92L7#Xgi`j9~gpk_rGm&eEˣϩ*>bk* 4$O`XD?. ۓ~KI5!VM{ȩR=wfS)m߳+ov^s}݅\ffS)lv3)]6?gK_/3{ݎ(:7ec2QH3cO{<_x݅\fwaE>ٻ,G}E#x͏W? 9zgF1Rmªʄ9nIƫ9wWv^s}FmWQDMzB֧:Q?o~e>fZ~/ov^s};?ӊxKqHbHȧknT|ױ! R9h>e>f| ;1m3 #I%RNt`bިr&Co+~z^8ZCVHE}CAnIxذx}8Ѓ$d0j(*BN34YVd8tt^SRՅY2"م PFoEQ8Ӟ;QqCfJ68% fci'H$Ǐ BL7J`e<q~9C@dZJh_!B`[PfpBijɮc59ˏB5ƽ‹Ӯ}vDfz]Xg_O-2i) 0"WζI 7R&CcQ+@]}E#x͗{%qTKit-yCQseR(:3{wv8{wbRT%)uz}EEHȷ7`RUL1ǬOV̎!$$GrxFJ.1%929U)XYG^SJ+I Qe2JZQ ð#tWiG(جdGTo1|ns |`~TQD9PjI Y<w zonRݝ)[K,`~H "5\RS*>74a'64M-2|8i/ c!|4pr/UZȪDµ4pqؽPL1K=FMsژ W:QD3qST Ym%TH֓Mc @yBmsƕ*".oVXVRlety&dmbPcG!2<}q3X /N>$VHĘ+j^2K `Whs0`&5`GJWs]]}E#x́v/k'6QzuϿnت^%ѭrko,Z-Hb̖9Y;E,p@F;ѴXsDv3)]6F;P]Nő >d[Qה.RcԔJE%?PnUty S2mP3>W&HS^;Q̨LG$țq1vΎɋy ƕ쐕,kTi0+틀m_r z*̂ $ZĎ @ȎЫM72fY^ƒ޲0I:h;,菸PeW ]v܉czXUFn01l5~UNյv2Tu 1"Kk `Agcw`yhӛ̌V̗\Yh`tٹK2^Rakg@GG(>@k.O{UO{UG{{_ >F~x~JF(Ikuڝ6"9p#l\UM5M]UMtZH>4qEi3B6s_jӱ_jӱookV("OlejuwX4nWRձ2R5/ŏ$(Z'`u:k=^+jQ cLclcuRƣQV܈6~`q!hq=4F,ԲӵH2_wLiPcwX{{o;=}1{ιbWqMۏukh86%hlVvJƝzB[SFFm0*uZ"O*Ϭm8E|-;-hXCnbQYxf9H$jUƨ}%t.D$rzdZ~AWzxmG] (UY'1k]T3B1s>{RWH' QQYLr.u|8Yr12 $aT{cU^D; CW\cd3-L&N` 1fҠ(|G (څIPmEycl9ƜQS%!bDfgfO]g^7ȨTTRy~'p4yET a!+1PIdysC͟f䁛D2yrp\3D׈\YZ$mʲiLkpDz3;8Ƭ4tCig %Յl^3[㠫QEr0|a359'̟C.*ji 4em$HbmU˨_b}nHe$mKJFX<^Siwۅc8c-Rr4JWXUcN L@#J=? "Isr+v/Ne0 &+$S0L>meM>wO`_]敶ZDuD/Tnj+(k3 j1J#b&~cnw$N䓇CfTٔDvQVTo1ӼNfSqlZ(eR[\\qoXBZ{,'M_=XXDXAql>y2dyֺYu:OZ͂qWHcӐUc93tJ}qDԙ(cMQFP ٴP: rDaQL4a`8N"#^!֪+Zʫ +L_mD` j*_9ac @G n6k_*(4Ut~vRy5\$+xf:1qbG GF܇#/)8oxxACs(IбFsFߴ6֝hOBJb"qz+q.L#,zȍ 2r$KԢb9XR~$=>SܪD8%6$YYA'rH k{aS<6 V [@rn{dQќw"쾮6>'׾\SXp"J[ܞ{#Yϐ˽# \ p1h-C3f5Bʤp*ӔGm҅_5Yg"͌Cd suKe,dbʟb$00,C466 F*QMz95wzXy@I[a{`;m`T@I9@1FƑkЏTh{0U|i^)kE 8lyQ\ hY:Ҷ.3WEMVX|^TUII5Lmty1יzk^S#%`cp6%SM8Xx1P iWujrBPS,]ֆJ,ӜrN@vN?1cUv(V b:pCyqaTbGjrlaFCsƭj=Zk|m:Γt19H+AC5\u%FKbIL$+urY]7fkY#O|%95BGSW[&5-ks jHtmvIaO ^7S_&DlfZK og&[6 +@ b#17ݴuEMuOHrУY9+#[6 :` kPjۙ: CJG`Ϋy!U'Ȑkw#V+4UBҨF&F% c~ҁkrƊf1I$;u i=u` _dsV|Hvq1 cJ5v!F+؈ƣʡ3mpDnb B4|`>hCkVŠ6Cj Яqxy{bQƎ7LsZ5+n߻zr*?col4B ~ikSđb0qtx P؍GF&*5Q۷0~g 0ͷhq,Q=>|pvf;3{`n¢}Mlvf666ݣ˟*'Ͽ/ޏy<6f`y8;3{`=xmͷhp 7ン0~g R?9Ya<y8images/toolbar/0040755000076400010020000000000007477023140012275 5ustar alexcvsimages/toolbar/absmode.gif0100644000076400010020000000020507401552675014377 0ustar alexcvsGIF89a!,@J(H+  G&gmN.xYo @'UfC"E~>N=`JM cQԪܙs ;images/toolbar/abspos.gif0100644000076400010020000000014707401552675014261 0ustar alexcvsGIF89a!,@8  s*ڸݴ: "0ى]!16e b2ӊ8!g¦,;images/toolbar/additem.gif0100644000076400010020000000030007401552675014370 0ustar alexcvsGIF89a{{{{!,@mpI';`y$hǠa;t0@l FE($6TY! +xpȈJQHl$wAGz.DvyU! \6;images/toolbar/bgcolor.gif0100644000076400010020000000030107401552675014411 0ustar alexcvsGIF89a{{{{!,@npIk0V_ %$A)eKٷE.Еdfr#8(WpM"WX41F@1 Eu =u3( + .xy ][;images/toolbar/bold.gif0100644000076400010020000000012207401552675013703 0ustar alexcvsGIF89a!,@){Ỽ{R'nWi~ʶTޣQ;images/toolbar/borders.gif0100644000076400010020000000017507401552675014433 0ustar alexcvsGIF89a!,@N #`4Ob4؉Ŷk`6t鍭I3GT Ce¡t^[ȞZi2'n IeF;images/toolbar/break.gif0100644000076400010020000000011407401552675014050 0ustar alexcvsGIF89a!,@# tݼi[}扦*CzmrX;images/toolbar/bring_above_text.gif0100644000076400010020000000020607401552675016307 0ustar alexcvsGIF89a! ,Kx0I{hR`I’l;̈́\)tkOB^?2 gΖ;images/toolbar/bring_forward.gif0100644000076400010020000000020507401552675015612 0ustar alexcvsGIF89a! ,JH0I؁{hR`Iv$"0XC.p8`#:US=RS) ;images/toolbar/bring_to_front.gif0100644000076400010020000000021407401552675016000 0ustar alexcvsGIF89a! ,QH0I;@ Mk%; k0>.B'ݮX^3ifA/HL̸+ ;images/toolbar/bullist.gif0100644000076400010020000000012507401552675014444 0ustar alexcvsGIF89a!,@&˝Aڋft86$Nwn;images/toolbar/button.gif0100644000076400010020000000032407401552675014302 0ustar alexcvsGIF89a320͜xxxjjjddd^^^¾! ,Q'dihlp,ϰ`߸=$`P`R Ur|SenU eL&W &n5UgNi~c!;images/toolbar/center.gif0100644000076400010020000000011107401552675014241 0ustar alexcvsGIF89a!,@ ڋ#dh`[vrW;images/toolbar/checkbox.gif0100644000076400010020000000057007401552675014560 0ustar alexcvsGIF89aɀ~~~}}}!!!ddd666888ж<<<RRR˵???)))UUU---! ?,pH,Ȥrl t:=$vHшH"F%r lmGoq wny!"#$ %&x '()* (+qy,*%z&{F-F .F N?A;images/toolbar/code.gif0100644000076400010020000000013307424124451013667 0ustar alexcvsGIF89a!,, ;dy*xHnץ} %;images/toolbar/copy.gif0100644000076400010020000000016307401552675013742 0ustar alexcvsGIF89a!,@D aYAIuj4*4Rdn*]\. EDJ9%@t2}ܮ;images/toolbar/createlink.gif0100644000076400010020000000012207401552675015104 0ustar alexcvsGIF89a!,)TyF'8 GfV>R;images/toolbar/cut.gif0100644000076400010020000000014307401552675013561 0ustar alexcvsGIF89a!,@4 X0S|9΋uHfV(Y}T ryƀsZ@ȺX^XΖ;images/toolbar/deindent.gif0100644000076400010020000000013507401552675014561 0ustar alexcvsGIF89a!,@.c\ڋ޼HG&5r sӀ$l*C"ODK;images/toolbar/delcell.gif0100644000076400010020000000017107401552675014373 0ustar alexcvsGIF89a!,@>( ʩBx M`qhq^h1:nͯ$G\T(XJxXT;images/toolbar/delcol.gif0100644000076400010020000000017007401552675014230 0ustar alexcvsGIF89a!,@=( APVhX͍<+V,H O;images/toolbar/delete.gif0100644000076400010020000000014007401552675014225 0ustar alexcvsGIF89a!,@1{dJҋs{8 3k.c;_wx.bx(;images/toolbar/delrow.gif0100644000076400010020000000017507401552675014267 0ustar alexcvsGIF89a!,@B J@y(R0th2X_(yJߪER2jLXs)M%;images/toolbar/details.gif0100644000076400010020000000020507401552675014412 0ustar alexcvsGIF89a!,@C N\L H9|h݉ -iВ6 $VׁRà\T;v|Xh \XŢjg ;images/toolbar/end.gif0100644000076400010020000000011307401552675013531 0ustar alexcvsGIF89a!,@"#t&)޼?,78"GHhe ;images/toolbar/font.gif0100644000076400010020000000013607401552675013736 0ustar alexcvsGIF89a! ,/4؀iW yg "d b;images/toolbar/font_color.gif0100755000076400010020000000022307424124451015124 0ustar alexcvsGIF89a!,@I8%%d}h*Jlzq7Ou?+Gx h:%JuN+z;images/toolbar/form.gif0100644000076400010020000000045407401552675013736 0ustar alexcvsGIF89a 975hfbXWS)(&ĽŽ¾ĦCA?NMJļƿtrn|zu¿! ?,IpH,Ȥrl:P#S  DÁx"#A"diB*$p5یFeGSUWY[]_aQA;images/toolbar/fullscrn.gif0100644000076400010020000000020407401552675014614 0ustar alexcvsGIF89a!,@I "*$`uhFUId,vAۆF,%گ83NJ*ʤB9` I.;images/toolbar/hr.gif0100644000076400010020000000010407401552675013374 0ustar alexcvsGIF89a! ,ڋ۸ʦ;images/toolbar/image.gif0100644000076400010020000000035307401552675014053 0ustar alexcvsGIF89a!,@cHeC(5*b_hKAgx޼@5΋"CdA@@`:nJZ#Y0Abn4YXukW=[Ż~oVU ;GoFSt `13O@ "zVC#35~C&GE5EGLP]rMTt{;images/toolbar/indent.gif0100644000076400010020000000013507424124451014240 0ustar alexcvsGIF89a!,@.qc\ڋ޼HG&5r i%l*C?OJ;images/toolbar/inindent.gif0100644000076400010020000000013507401552675014577 0ustar alexcvsGIF89a!,@.qc\ڋ޼HG&5r i%l*C?OJ;images/toolbar/inscell.gif0100644000076400010020000000017207401552675014421 0ustar alexcvsGIF89a!,@?(.}hmhhd[B5ۀիj5I$ )&QK+.;images/toolbar/inscol.gif0100644000076400010020000000016607401552675014262 0ustar alexcvsGIF89a!,@;(. ͩ`(VD)@I\ຣ`al8gq&R`"m^Oh.Mn;images/toolbar/insertorderedlist.gif0100644000076400010020000000011407401552675016531 0ustar alexcvsGIF89a!,# QJP`7ئ]劈m;images/toolbar/insertunorderedlist.gif0100644000076400010020000000011407401552675017074 0ustar alexcvsGIF89a!,#`>ۦʪPp6X;images/toolbar/insrow.gif0100644000076400010020000000017407401552675014313 0ustar alexcvsGIF89a!,@Ao(B8`#hxئ:C]* V9/Y;images/toolbar/lock.gif0100644000076400010020000000013007401552675013712 0ustar alexcvsGIF89a!,@){ Xaݼ؍`hb[Y)Ox~P;images/toolbar/make_absolute.gif0100644000076400010020000000014007401552675015576 0ustar alexcvsGIF89a! ,1tU{QX@HʞQXrxĢx(;images/toolbar/mrgcell.gif0100644000076400010020000000021707401552675014415 0ustar alexcvsGIF89a!,@T( I{O(BYUlB^Cs`Fd \1jXz< yFF>FF?@@@JJBKKCKKDMMENNNPPPdddooorrfssgyys|||tty}îïįʵη͸ϹйѹҼӼստֿ!,5%Z`/RWZZ7PPWdk }} PXdgknu/yy K8 Buuy"7+IEBvwʂM +iyBww>P~B8%Zd "<4+@gxB+QXb)K2FaAEvKhdG;images/toolbar/paste.gif0100644000076400010020000000022007401552675014076 0ustar alexcvsGIF89a!,@UH @+- 'hE6 ^g,OfP X!ml.9Ɉ)ToR-P{ C-=|m\;images/toolbar/print.gif0100644000076400010020000000020107401552675014115 0ustar alexcvsGIF89a!,@F @0wfUHqby_UMu( x4|p5H< 'TX#ԧ,Un0$;images/toolbar/project.gif0100644000076400010020000000022507401552675014435 0ustar alexcvsGIF89a!,@Z(P"TA>$jQY,t#EME]a&&Xmɤ 20eVBl J  "#$%&'")#"*+I $,-./0K23o-45tK 65%.578M&/O 'ЮPLA;images/toolbar/reddot.gif0100644000076400010020000000252707401552675014257 0ustar alexcvsGIF89aH̙ffff333̙̙f33f33fffff333333333333,H@`%dihlp,tmx> BpHx$ $}K$h$'d&^/`#x+>lJ-E S GG>m=·ć̈҇eהۜদ娞橲F ƹ? SÊg̐⇯h 14mym8I} 1(S7` (DW}WxkCKZxVi \'yB- 0BM%" @קV6&{H쉮eB{ ǭј QCf|)]e_\y1FKEsREЅpDC& a"#M\[8K+DI;images/toolbar/redo.gif0100644000076400010020000000012707401552675013721 0ustar alexcvsGIF89a!,@( ,ЖZ\u扦!MqRR g;images/toolbar/reply.gif0100644000076400010020000000013607424124451014113 0ustar alexcvsGIF89a!,/2ņS )azh:6:g ׬ ;images/toolbar/right.gif0100644000076400010020000000011107401552675014076 0ustar alexcvsGIF89a!,@ ڋa$Md2 ݼ;images/toolbar/save.gif0100644000076400010020000000016707401552675013732 0ustar alexcvsGIF89a{{!,@H;2 FxP΁ivJ)ĶH"\VeM 7FĖ%G>2 Yf4:@,a;images/toolbar/saveall.gif0100644000076400010020000000017507401552675014422 0ustar alexcvsGIF89a{{!,@N:2\tN6ǥ꺢,n8W8_! ch!fZ*e[ %2F;images/toolbar/saveas.gif0100644000076400010020000000017507401552675014255 0ustar alexcvsGIF89a{{!,@N:2\tN6ǥ꺢,n8W8_! ch!fZ*e[ %2F;images/toolbar/select.gif0100644000076400010020000000117507401552675014253 0ustar alexcvsGIF89a®ƿ)))%%%888###ooo666 LLLhhhִ~~~uuuWWW|||;;;yyyOOOMMM111$$$vvvJJJ꣣''' ! ,ڀ    Ļ !"#$Ѩ%&'()*+,-'./.012 ( 3454Xq`A Z,U!"a= PP@Yl !R$#'RI%&,)@@hQ*]ʴ)@;images/toolbar/send_above_text.gif0100644000076400010020000000022207401552675016135 0ustar alexcvsGIF89a! ,Wx0I;@ Mk% ¬'+/\@' IDA֊IK݆5jp셴[;images/toolbar/send_back.gif0100644000076400010020000000020407401552675014675 0ustar alexcvsGIF89a! ,IH0I؁{hR`p#C9F+hBpM'+:@>Mq?8NfL&';images/toolbar/send_below_text.gif0100644000076400010020000000020707401552675016154 0ustar alexcvsGIF89a! ,Lx0I{hR`I’|wҊ7tAo9!LBFgDbCZ3hj;images/toolbar/send_forward.gif0100644000076400010020000000020507401552675015442 0ustar alexcvsGIF89a! ,JH0I؁{hR`Iv$"0XC.p8`#:US=RS) ;images/toolbar/send_to_back.gif0100644000076400010020000000021307401552675015377 0ustar alexcvsGIF89a! ,PH0I;@ M ^08:;D>ߏ C\fUn!Tkʠ"'ö$;images/toolbar/snapgrid.gif0100644000076400010020000000017707401552675014604 0ustar alexcvsGIF89a!,@D(9a)@iZ⨮l8 ΣD8<@&@\:GEbVʅMW#;images/toolbar/spltcell.gif0100644000076400010020000000021207401552675014605 0ustar alexcvsGIF89a!,@O( I{O(B\`z8l _)pHtU FObD 쯺fW S/cqJ;images/toolbar/start.gif0100644000076400010020000000011107401552675014116 0ustar alexcvsGIF89a!,@ ›X\HYjŮ;images/toolbar/strike.gif0100644000076400010020000000012507424124451014257 0ustar alexcvsGIF89a!,&={EЧZeER;images/toolbar/tasklist.gif0100644000076400010020000000021207401552675014621 0ustar alexcvsGIF89a!,@O8)EqvB(| X0yd̴f(WlH,!ar/jR HJڜG>hhq K;images/toolbar/text.gif0100644000076400010020000000113307401552675013752 0ustar alexcvsGIF89a»}}}tttsss<<?@ 7ABC 2DEtI{ @I ` &ś'P$2 U\0c E˖ 1y.\vf鲓CDƎ/`Gp <2Cje J: #;H1Á2!/ =4hk+^XP ;images/toolbar/under.gif0100644000076400010020000000013207401552675014101 0ustar alexcvsGIF89a{{{!,@+{"rʋXWEʶz]Ϊ9@ & ;images/toolbar/underline.gif0100644000076400010020000000013207401552675014751 0ustar alexcvsGIF89a{{{!,@+{"rʋXWEʶz]Ϊ9@ & ;images/toolbar/undo.gif0100644000076400010020000000012507401552675013733 0ustar alexcvsGIF89a!,@&+p^`ڻN`"e㉦Ji5fc;private/0040777000076400010020000000000007477023142011046 5ustar alexcvsprivate/lib/0040755000076400010020000000000007477023142011610 5ustar alexcvsprivate/lib/GT/0040755000076400010020000000000007477023142012122 5ustar alexcvsprivate/lib/GT/AutoLoader.pm0100644000076400010020000002435107475214470014525 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::AutoLoader # Author: Jason Rhinelander # $Id: AutoLoader.pm,v 1.7 2002/05/29 18:08:56 jagerman Exp $ # # Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved. # ================================================================== package GT::AutoLoader; use vars qw($AUTOLOAD %LOG %PACKAGES); use strict qw/vars subs/; # no strict 'refs' - we need several soft references here. sub import { shift; # Discard the package, as 'use GT::AutoLoader' calls GT::AutoLoader->import(ARGS) my %opts = @_; my $pkg = caller; ++$PACKAGES{$pkg}; if ($opts{LOG} and ref $opts{LOG} eq 'CODE') { $LOG{$pkg} = delete $opts{LOG}; # Everything that requests a log will get one for all modules } delete $opts{NAME} if $opts{NAME} and $opts{NAME} eq 'AUTOLOAD'; # Allows "if ($opts{NAME})" later on. my $COMPILE; *{$pkg . ($opts{NAME} ? "::$opts{NAME}" : '::AUTOLOAD')} = sub { if ($opts{NAME} or !$AUTOLOAD) { # If they're using another name, it most likely means they are wrapping the AUTOLOAD, which means we have to check for $AUTOLOAD in their package. $AUTOLOAD = ${$pkg . '::AUTOLOAD'}; } my ($func) = $AUTOLOAD =~ /([^:]+)$/; # How odd - we use $GT::AutoLoader::AUTOLOAD, even though this is run in some other package if ($COMPILE = \%{$pkg . '::COMPILE'}) { if (defined $COMPILE->{$func}) { for (keys %LOG) { $LOG{$_}->($pkg, $func, 'COMPILE') } _compile($COMPILE, $pkg, $func); $AUTOLOAD = ''; goto &{"$pkg\::$func"}; } } if ($opts{NEXT}) { my ($pack, $func) = $opts{NEXT} =~ /(?:(.+)::)?([^:]+?)$/; $pack ||= $pkg; ${$pack . '::AUTOLOAD'} = $AUTOLOAD; my $next = "$pack\::$func"; $AUTOLOAD = ''; goto &$next; } # It doesn't exist in %COMPILE, which means we have to look through @ISA for another AUTOLOAD to pass this to if (my @inh = @{"$pkg\::ISA"}) { while (my $inh = shift @inh) { my $al = $inh . '::AUTOLOAD'; if (defined &$al) { $$al = "$pkg\::$func"; # Sets $Other::Package::AUTOLOAD $AUTOLOAD = ''; goto &$al; } elsif (my @isa = @{$inh . '::ISA'}) { unshift @inh, @isa; } } } my ($file, $line) = (caller)[1,2]; $AUTOLOAD = ''; die "$pkg ($$, GT::AutoLoader): Unknown method '$func' called at $file line $line.\n"; }; my $compile = "$pkg\::COMPILE"; *$compile = \%$compile; # Implements "use vars qw/%COMPILE/" for you 1; } BEGIN { if ($^C) { eval q{ sub CHECK { # ------------------------------------------------------------------------------ # In Perl 5.6+ this allows you to do: perl -cMMy::Module -e0 to make sure all # your %COMPILE subs compile In versions of Perl prior to 5.6, this is simply # treated as a sub named "CHECK", which is never called. $^C is also 5.6+ # specific - whether or not you are running under "-c" compile_all(); } }; } } sub compile_all { my @pkg = @_; if (@pkg) { @pkg = grep +($PACKAGES{$_} or (warn "$_ is not loaded, does not use GT::AutoLoader, or is not a valid package" and 0)), @pkg; @pkg or die "No valid packages passed to compile_all()!"; } else { @pkg = keys %PACKAGES; } for my $pkg (@pkg) { my $COMPILE = \%{$pkg . '::COMPILE'} or next; for my $func (keys %$COMPILE) { _compile($COMPILE, $pkg, $func); } } return 1; } sub _compile { # ------------------------------------------------------------------------------ # Compiles a subroutine from a module's %COMPILE into the module's package. # die()s if the subroutine cannot compile or still does not exist after # compiling. Takes three arguments: A reference to the packages %COMPILE hash, # the package, and the name of the function to load. # my ($COMPILE, $pkg, $func) = @_; my $linenum = ($COMPILE->{$func} =~ s/^(\d+)//) ? $1+1 : 0; eval "package $pkg;\n#line $linenum$pkg\::$func\n$COMPILE->{$func}"; if ($@) { die "Unable to load $pkg\::$func: $@" } if (not defined &{"$pkg\::$func"}) { die "Unable to load $pkg\::$func: Subroutine did not compile correctly (possible bad name)."; } undef $COMPILE->{$func}; # Leave the key in the compile hash so that things can test to see if it was defined in the compile hash return; } 1; __END__ =head1 NAME GT::AutoLoader - load subroutines on demand =head1 SYNOPSIS package GT::Module; use GT::AutoLoader; # You now have an AUTOLOAD subroutine that will check for entries in %COMPILE or package GT::OtherModule; use GT::AutoLoader(NAME => '_AUTOLOAD'); # Import AUTOLOAD as _AUTOLOAD, define our own AUTOLOAD sub AUTOLOAD { ... goto &_AUTOLOAD; } then: $COMPILE{sub} = __LINE__ . <<'END_OF_SUB'; sub method_name { ... } END_OF_SUB =head1 DESCRIPTION The B module works as a way to speed up your code. Currently, the only thing it does is scan for a %COMPILE hash in your package. If it finds it, it looks for the subroutine you called, and if found compiles and runs it. If unable to find a subroutine to compile in %COMPILE, B will scan your inheritance tree (@ISA) for another AUTOLOAD subroutine to pass this off to. If there isn't any, a fatal error occurs. To use B, in its standard behaviour, simply put: C in your module. When you use GT::AutoLoader, two things will happen. First, an C subroutine will be imported into your namespace that will automatically compile your subroutines only when they are needed, thus speeding up compile time. Secondly, a %COMPILE hash will be defined in your package, eliminating the need for you to: use vars qw/%COMPILE/; =head1 USE You can pass options to GT::AutoLoader to change the behaviour of the module. Currently, logging is the only option, however more options (perhaps including a different compiling scheme) will be added at some future point. Options are specified as import() arguments. For example: use GT::AutoLoader(OPTION => "value"); =over 4 =item NAME If you want to import the autoload subroutine as something other than 'Package::AUTOLOAD', the 'NAME' option should be used. Its value is the name to import as. For example, to import a GT::AutoLoader AUTOLOAD named _AUTOLOAD (this is useful when declaring your own AUTOLOAD behaviour, but still using GT::AutoLoader's behaviour as a fallback), you would do something like: use GT::AutoLoader(NAME => '_AUTOLOAD'); =item LOG Takes a code reference as its value. The code reference will be called three arguments - the package name, the name of the function, and the autoload method (Currently only 'COMPILE'). Note that this will be called for ALL autoloaded subroutines, not just the ones in your package. WARNING - you cannot put code in your log that relies on autoloaded methods - you'll end up throwing the program into an infinite loop. For example, to get a line of debugging after each subroutine is compiled, you could C like this: use GT::AutoLoader(LOG => sub { print "Compiled $_[1] in package $_[0]\n" }); =item NEXT Normally, GT::AutoLoader will look for another AUTOLOAD to call in your package's @ISA inheritance tree. You can alter this behaviour and tell GT::AutoLoader what to call next using the NEXT option. For example, if you have a sub _AUTOLOAD { } that you wanted to call if the method isn't found by GT::AutoLoader, you would use GT::AutoLoader like this: use GT::AutoLoader(NEXT => 'Package::Name::_AUTOLOAD'); The _AUTOLOAD function in your package will now be called if GT::AutoLoader can't load the method on its own. $AUTOLOAD will be set for you in whichever package the function you provide is in. Note that if you simply want to use an inherited AUTOLOAD, you B use this option; GT::AutoLoader will handle that just fine on its own. You may omit the package (Package::Name::) if the function is in your current package. =back =head1 compile_all A function exists in GT::AutoLoader to compile all %COMPILE-subroutines. By default (without arguments) compile_all() compiles every %COMPILE-subroutine in every package that has used GT::AutoLoader. You can, however, pass in a list of packages which compile_all() will check instead of compiling everything. Note that GT::AutoLoader will only compile %COMPILE-subroutines in packages that have used GT::AutoLoader, so if you specify package "Foo", but "Foo" hasn't used GT::AutoLoader, it will be ignored. You can do something like: GT::AutoLoader::compile_all(__PACKAGE__) if $MOD_PERL; to have a GT::AutoLoader compile every %COMPILE-subroutine in the current package automatically under mod_perl, or you could add this code to your mod_perl startup file or test script: GT::AutoLoader::compile_all; Test scripts should definately use compile_all() to ensure that all subroutines compile correctly! =head1 REQUIREMENTS None. =head1 WARNINGS Due to the nature of Perl's AUTOLOAD handling, you must take care when using GT::AutoLoader in a subclass. In short, subclassed methods B be put into the %COMPILE hash. The problem is that since the subroutine does not exist in the package, Perl, while decending the inheritance tree, will not see it but will probably see the parent's method (unless nothing else has called the method, but you should never count on that), and call it rather than looking for your package's AUTOLOAD. This isn't to say that subclasses cannot use AUTOLOAD - just that subclasses cannot use autoloaded methods (%COMPILE-subroutines) if a method of the same name exists in the parent class. Autoloaded function calls are not affected. =head1 MAINTAINER Jason Rhinelander =head1 SEE ALSO L =head1 COPYRIGHT Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved. http://www.gossamer-threads.com/ =head1 VERSION Revision: $Id: AutoLoader.pm,v 1.7 2002/05/29 18:08:56 jagerman Exp $ =cut private/lib/GT/Base.pm0100644000076400010020000006370107475745704013353 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::Base # Author : Alex Krohn # $Id: Base.pm,v 1.108 2002/05/31 19:15:16 jagerman Exp $ # # Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: # Base module that handles common functions like initilization, # debugging, etc. Should not be used except as a base class. # package GT::Base; # =============================================================== require 5.004; # We need perl 5.004 for a lot of the OO features. use strict qw/vars subs/; # No refs as we do some funky stuff. use vars qw/$AUTOLOAD $DEBUG $VERSION $ATTRIB_CACHE $MOD_PERL $SPEEDY $PERSIST %ERRORS/; use GT::AutoLoader(NEXT => 'GT::Base::_AUTOLOAD'); $DEBUG = 0; $VERSION = sprintf "%d.%03d", q$Revision: 1.108 $ =~ /(\d+)\.(\d+)/; $MOD_PERL = (exists $ENV{GATEWAY_INTERFACE} and ($ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl/)) ? 1 : 0; $SPEEDY = ($CGI::SpeedyCGI::_i_am_speedy or $CGI::SpeedyCGI::i_am_speedy) ? 1 : 0; $PERSIST = $MOD_PERL || $SPEEDY; $ATTRIB_CACHE = {}; %ERRORS = ( MKDIR => "Could not make directory (%s). Reason: %s", OPENDIR => "Could not open directory (%s). Reason: %s", RMDIR => "Could not remove directory (%s). Reason: %s", CHMOD => "Could not chmod (%s). Reason: %s", UNLINK => "Could not unlink (%s). Reason: %s", READOPEN => "Could not open (%s) for reading. Reason: %s", WRITEOPEN => "Could not open (%s) for writting. Reason: %s", OPEN => "Could not open (%s). Reason: %s", BADARGS => "Wrong argument passed to this subroutine. Usage: %s" ); sub import { # ------------------------------------------------------- # Only exports $MOD_PERL, $SPEEDY, and $PERSIST. # my $pkg = shift; my %symbol = map { $_ => 1 } @_; my $callpkg = caller; *{$callpkg . '::MOD_PERL'} = \$MOD_PERL if $symbol{'$MOD_PERL'} or $symbol{':all'}; *{$callpkg . '::SPEEDY'} = \$SPEEDY if $symbol{'$SPEEDY'} or $symbol{':all'}; *{$callpkg . '::PERSIST'} = \$PERSIST if $symbol{'$PERSIST'} or $symbol{':all'}; return; } sub new { # ------------------------------------------------------- # Create a base object and use set or init to initilize anything. # my $this = shift; my $class = ref $this || $this; # Create self with our debug value. my $self = { _debug => defined ${"$class\:\:DEBUG"} ? ${"$class\:\:DEBUG"} : $DEBUG }; bless $self, $class; $self->debug ("Created new $class object.") if ($self->{_debug} > 2); # Set initial attributes, and then run init function or call set. $self->reset; if ($self->can('init')) { $self->init(@_); } else { $self->set(@_) if (@_); } if ( index ($self, 'HASH') != -1 ) { $self->{_debug} = $self->{debug} if $self->{debug}; } return $self; } sub DESTROY { # ------------------------------------------------------- # Object is nuked. # (index ($_[0], 'HASH') > -1) or return; if ($_[0]->{_debug} and $_[0]->{_debug} > 2) { my ($package, $filename, $line) = caller; $_[0]->debug ("Destroyed $_[0] in package $package at $filename line $line."); } } sub _AUTOLOAD { # ------------------------------------------------------- # We use autoload to provide an accessor/setter for all # attributes. # my ($self, $param) = @_; my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/; # If this is a known attribute, return/set it and save the function # to speed up future calls. my $autoload_attrib = 0; if (ref $self and (index ($self, 'HASH') != -1) and exists $self->{$attrib} and ! exists $COMPILE{$attrib}) { $autoload_attrib = 1; } else { # Class method possibly. if (! ref $self) { my $attribs = $ATTRIB_CACHE->{$self} || _get_attribs($self); if (exists $attribs->{$attrib}) { $autoload_attrib = 1; } } } # This is an accessor, create a function for it. if ($autoload_attrib) { *{$AUTOLOAD} = sub { if (! ref $_[0]) { # Class Method my $attribs = $ATTRIB_CACHE->{$_[0]} || _get_attribs($_[0]); if (@_ > 1) { $_[0]->debug ("Setting base attribute '$attrib' => '$_[1]'.") if (defined ${$_[0] . '::DEBUG'} and (${$_[0] . '::DEBUG'} > 2)); $ATTRIB_CACHE->{$_[0]}->{$attrib} = $_[1]; } return $ATTRIB_CACHE->{$_[0]}->{$attrib}; } if (@_ > 1) { # Instance Method $_[0]->debug ("Setting '$attrib' => '$_[1]'.") if (defined $_[0]->{_debug} and ($_[0]->{_debug} > 2)); $_[0]->{$attrib} = $_[1]; } return $_[0]->{$attrib}; }; goto &$AUTOLOAD; } # Otherwise we have an error, let's help the user out and try to # figure out what they were doing. _generate_fatal($self, $attrib, $param); } sub set { # ------------------------------------------------------- # Set one or more attributes. # return unless (@_); if ( !ref $_[0]) { class_set(@_); } else { my $self = shift; my $p = $self->common_param (@_) or return $self->error ('BADARGS', 'FATAL', "Argument to set must be either hash, hash ref, array, array ref or CGI object."); my $attribs = $ATTRIB_CACHE->{ref $self} || _get_attribs (ref $self); my $f = 0; $attribs->{debug} = 0 unless exists $attribs->{debug}; foreach my $attrib (keys %$attribs) { next unless (exists $p->{$attrib}); $self->debug ("Setting '$attrib' to '${$p}{$attrib}'.") if ($self->{_debug} > 2); $self->{$attrib} = $p->{$attrib}; $f++; } return $f; } } sub common_param { # ------------------------------------------------------- # Expects to find $self, followed by one or more arguments of # unknown types. Converts them to hash refs. # shift; my $out = {}; return $out unless (@_ and defined $_[0]); CASE: { (ref $_[0] eq 'HASH') and do { $out = shift; last CASE; }; (UNIVERSAL::can ($_[0], 'get_hash')) and do { $out = $_[0]->get_hash; last CASE; }; (UNIVERSAL::can ($_[0], 'param')) and do { foreach ($_[0]->param) { my @vals = $_[0]->param($_); $out->{$_} = (@vals > 1) ? \@vals : $vals[0]; } last CASE; }; (defined $_[0] and not @_ % 2) and do { $out = {@_}; last CASE; }; return; } return $out; } sub reset { # ------------------------------------------------------- # Resets all attribs in $self. # my $self = shift; my $class = ref $self; my $attrib = $ATTRIB_CACHE->{$class} || _get_attribs ($class); # Deep copy hash and array refs only. while (my ($k, $v) = each %$attrib) { if (! ref $v) { $self->{$k} = $v; } elsif (ref $v eq 'HASH') { $self->{$k} = {}; foreach my $k1 (keys %{$attrib->{$k}}) { $self->{$k}->{$k1} = $attrib->{$k}->{$k1}; } } elsif (ref $v eq 'ARRAY') { $self->{$k} = []; foreach my $v1 (@{$attrib->{$k}}) { push @{$self->{$k}}, $v1; } } else { $self->{$k} = $v; } } } sub _get_attribs { # ------------------------------------------------------- # Searches through ISA and returns this packages attributes. # my $class = shift; my $attrib = defined ${"$class\:\:ATTRIBS"} ? ${"$class\:\:ATTRIBS"} : {}; my @pkg_isa = defined @{"$class\:\:ISA"} ? @{"$class\:\:ISA"} : (); foreach my $pkg (@pkg_isa) { next if ($pkg eq 'Exporter'); # Don't mess with Exporter. next if ($pkg eq 'GT::Base'); my $fattrib = defined ${"$pkg\:\:ATTRIBS"} ? ${"$pkg\:\:ATTRIBS"} : next; foreach (keys %{$fattrib}) { $attrib->{$_} = $fattrib->{$_} unless exists $attrib->{$_}; } } $ATTRIB_CACHE->{$class} = $attrib; return $attrib; } $COMPILE{debug} = __LINE__ . <<'END_OF_FUNC'; sub debug { # ------------------------------------------------------- # Displays a debugging message. # my ($self, $msg) = @_; my $pkg = ref $self || $self; # Add line numbers if asked for. if ($msg !~ /\r?\n$/) { my ($package, $file, $line) = caller; $msg .= " at $file line $line.\n"; } # Remove windows linefeeds (breaks unix terminals). $msg =~ s/\r//g unless ($^O eq 'MSWin32'); $msg =~ s/\n(?=[^ ])/\n\t/g; print STDERR "$pkg ($$): $msg"; } END_OF_FUNC $COMPILE{debug_level} = __LINE__ . <<'END_OF_FUNC'; sub debug_level { # ------------------------------------------------------- # Set the debug level for either the class or object. # if (ref $_[0]) { @_ > 1 and ($_[0]->{_debug} = $_[1]); return $_[0]->{_debug}; } else { my $pkg = shift; if (@_) { my $level = shift; ${"$pkg\:\:DEBUG"} = $level; } return ${"$pkg\:\:DEBUG"}; } } END_OF_FUNC $COMPILE{warn} = __LINE__ . <<'END_OF_FUNC'; sub warn { shift->error(shift, WARN => @_) } END_OF_FUNC $COMPILE{fatal} = __LINE__ . <<'END_OF_FUNC'; sub fatal { shift->error(shift, FATAL => @_) } END_OF_FUNC $COMPILE{error} = __LINE__ . <<'END_OF_FUNC'; sub error { # ------------------------------------------------------- # Error handler. # my $self = shift; my ($msg, $level, @args) = @_; my $pkg = ref $self || $self; $level = defined $level ? $level : 'FATAL'; my $is_hash = index ($self, 'HASH') != -1; # Load the ERROR messages. $self->set_basic_errors; # err_pkg stores the package just before the users program for displaying where the error was raised # think advanced croak. my $err_pkg = $pkg; if ($is_hash) { $err_pkg = defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg; } # initilize vars to silence -w warnings. # msg_pkg stores which package error messages are stored, defaults to self, but doesn't have to be. ${$pkg . '::ERROR_MESSAGE'} ||= ''; my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg; my $debug = $is_hash ? $self->{_debug} : ${$pkg . "::DEBUG"}; # cls_err stores the actual error hash (error_code => error_string). Initilize to prevent -w # warnings. ${$msg_pkg . '::ERRORS'} ||= {}; ${$pkg . '::ERRORS'} ||= {}; my $cls_err = ${$msg_pkg . '::ERRORS'}; my $pkg_err = ${$pkg . '::ERRORS'} || $pkg; my %messages = %$cls_err; foreach (keys %$pkg_err) { $messages{$_} = $pkg_err->{$_}; } # Return current error if not called with arguments. if ($is_hash) { $self->{_error} ||= []; if (@_ == 0) { my @err = @{$self->{_error}} ? @{$self->{_error}} : (${$msg_pkg . "::error"}); return wantarray ? @err : defined($err[0]) ? $err[0] : undef; } } elsif (@_ == 0) { return ${$msg_pkg . '::errcode'}; } # Set a subroutine that will clear out the error class vars, and self vars under mod_perl. $MOD_PERL and $Apache::ServerStarting != 1 and Apache->request->register_cleanup( sub { $self->_cleanup_obj ($msg_pkg, $is_hash); } ); $SPEEDY and CGI::SpeedyCGI->register_cleanup ( sub { $self->_cleanup_obj ($msg_pkg, $is_hash); } ); # store the error code. ${$msg_pkg . '::errcode'} ||= ''; ${$msg_pkg . '::errcode'} = $msg; ${$msg_pkg . '::errargs'} ||= ''; if ($is_hash) { $self->{_errcode} = $msg; $self->{_errargs} = @args ? [@args] : []; } # format the error message. if (keys %messages) { if (exists $messages{$msg}) { $msg = $messages{$msg}; } $msg = $msg->() if ref $msg eq 'CODE'; $msg = @args ? sprintf ($msg, map { defined $_ ? $_ : '[undefined]' } @args) : $msg; $msg =~ s/(?:\r?\n)|\r/\n/g unless ($^O eq 'MSWin32'); $msg =~ s/\n(?=[^ ])/\n\t/g; } # set the formatted error to $msg_pkg::error. push @{$self->{_error}}, $msg if ($is_hash); # If we have a fatal error, then we either send it to error_handler if # the user has a custom handler, or print our message and die. # initlize error to silence -w warnings. ${$msg_pkg . '::error'} ||= ''; if (uc $level eq 'FATAL') { ${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? _format_err($err_pkg, \$msg) : _format_err($err_pkg, $msg); die (_format_err($err_pkg, $msg)) if in_eval(); if (exists($SIG{__DIE__}) and $SIG{__DIE__}) { die _format_err($err_pkg, $msg); } else { print STDERR _format_err($err_pkg, $msg); die "\n"; } } # Otherwise we set the error message, and print it if we are in debug mode. elsif (uc $level eq 'WARN') { ${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? \$msg : $msg; my $warning = _format_err($err_pkg, $msg); $debug and ( $SIG{__WARN__} ? CORE::warn $warning : print STDERR $warning ); $debug > 1 and ( $SIG{__WARN__} ? CORE::warn stack_trace('GT::Base',1) : print STDERR stack_trace('GT::Base',1) ); } return; } END_OF_FUNC $COMPILE{_cleanup_obj} = __LINE__ . <<'END_OF_FUNC'; sub _cleanup_obj { # ------------------------------------------------------- # Cleans up the self object under a persitant env. # my ($self, $msg_pkg, $is_hash) = @_; ${$msg_pkg . '::errcode'} = undef; ${$msg_pkg . '::error'} = undef; ${$msg_pkg . '::errargs'} = undef; if ($is_hash) { defined $self and $self->{_errcode} = undef; defined $self and $self->{_error} = undef; defined $self and $self->{_errargs} = undef; } return 1; } END_OF_FUNC $COMPILE{errcode} = __LINE__ . <<'END_OF_FUNC'; sub errcode { # ------------------------------------------------------- # Returns the last error code generated. # my $self = shift; my $is_hash = index ($self, 'HASH') != -1; my $pkg = ref $self || $self; my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg; if (ref $self and $is_hash) { return $self->{_errcode}; } else { return ${$msg_pkg . '::errcode'}; } } END_OF_FUNC $COMPILE{errargs} = __LINE__ . <<'END_OF_FUNC'; sub errargs { # ------------------------------------------------------- # Returns the arguments from the last error. In list # context returns an array, in scalar context returns # an array reference. # my $self = shift; my $is_hash = index ($self, 'HASH') != -1; my $pkg = ref $self || $self; my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg; my $ret = []; if (ref $self and $is_hash) { $self->{_errargs} ||= []; $ret = $self->{_errargs}; } else { ${$msg_pkg . '::errcode'} ||= []; $ret = ${$msg_pkg . '::errargs'}; } return wantarray ? @{$ret} : $ret; } END_OF_FUNC $COMPILE{clear_errors} = __LINE__ . <<'END_OF_SUB'; sub clear_errors { # ------------------------------------------------------- # Clears the error stack # my $self = shift; $self->{_error} = []; $self->{_errargs} = []; $self->{_errcode} = undef; return 1; } END_OF_SUB $COMPILE{set_basic_errors} = __LINE__ . <<'END_OF_FUNC'; sub set_basic_errors { # ------------------------------------------------------- # Sets basic error messages commonly used. # my $self = shift; my $class = ref $self || $self; if (${$class . '::ERROR_MESSAGE'}) { $class = ${$class . '::ERROR_MESSAGE'}; } ${$class . '::ERRORS'} ||= {}; my $err = ${$class . '::ERRORS'}; for my $key (keys %ERRORS) { $err->{$key} = $ERRORS{$key} unless exists $err->{$key}; } } END_OF_FUNC $COMPILE{in_eval} = __LINE__ . <<'END_OF_FUNC'; sub in_eval { # ------------------------------------------------------- # Current perl has a variable for it, old perl, we need to look # through the stack trace. Ugh. # my $ineval; if ($] >= 5.005 and !($MOD_PERL or $SPEEDY)) { $ineval = defined ($^S) ? $^S : (stack_trace('GT::Base',1) =~ /\(eval\)/); } elsif ($MOD_PERL or $SPEEDY) { my $stack = stack_trace('GT::Base', 1); my $cnt = $stack =~ s|\(eval\)(?!\s+called at\s+/dev/null)||g; $ineval = ($cnt > 1); } else { my $stack = stack_trace('GT::Base', 1); $ineval = $stack =~ /\(eval\)/; } return $ineval; } END_OF_FUNC $COMPILE{class_set} = __LINE__ . <<'END_OF_FUNC'; sub class_set { # ------------------------------------------------------- # Set the class init attributes. # my $pkg = shift; my $attribs = $ATTRIB_CACHE->{$pkg} || _get_attribs ($pkg); if (ref $attribs ne 'HASH') { return; } # Figure out what we were passed in. my $out = GT::Base->common_param(@_) or return; # Set the attribs. foreach (keys %$out) { exists $attribs->{$_} and ($attribs->{$_} = $out->{$_}); } } END_OF_FUNC $COMPILE{attrib} = __LINE__ . <<'END_OF_FUNC'; sub attrib { # ------------------------------------------------------- # Returns a list of attributes. # my $class = ref $_[0] || $_[0]; my $attribs = $ATTRIB_CACHE->{$class} || _get_attribs ($class); return wantarray ? %$attribs : $attribs; } END_OF_FUNC $COMPILE{stack_trace} = __LINE__ . <<'END_OF_FUNC'; sub stack_trace { # ------------------------------------------------------- # If called with arguments, returns stack trace, otherwise # prints to stdout/stderr depending on whether in cgi or not. # my $pkg = shift || 'Unknown'; my $raw = shift || 0; my $rollback = shift || 3; my ($ls, $spc, $fh); if ($raw) { if (defined $ENV{REQUEST_METHOD}) { $ls = "\n"; $spc = '   '; } else { $ls = "\n"; $spc = ' '; } } elsif (defined $ENV{REQUEST_METHOD}) { print STDOUT "Content-type: text/html\n\n"; $ls = '
'; $spc = ' '; $fh = \*STDOUT; } else { $ls = "\n"; $spc = ' '; $fh = \*STDERR; } my $out = $raw ? '' : "${ls}STACK TRACE$ls======================================$ls"; { package DB; my $i = $rollback; local $@; while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) { my @args; for (@DB::args) { eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference my $print = $@ ? \$_ : $_; push @args, defined $print ? $print : '[undef]'; } if (@args) { my $args = join ", ", @args; $args =~ s/\n\s*\n/\n/g; $args =~ s/\n/\n$spc$spc$spc$spc/g; $out .= qq!$pkg ($$): $sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!; } else { $out .= qq!$pkg ($$): $sub called at $file line $line with no arguments.$ls!; } } } $raw ? return $out : print $fh $out; } END_OF_FUNC $COMPILE{_format_err} = __LINE__ . <<'END_OF_FUNC'; sub _format_err { # ------------------------------------------------------- # Formats an error message for output. # my ($pkg, $msg) = @_; my ($file, $line) = get_file_line ($pkg); return "$pkg ($$): $msg at $file line $line.\n"; } END_OF_FUNC $COMPILE{get_file_line} = __LINE__ . <<'END_OF_FUNC'; sub get_file_line { # ------------------------------------------------------- # Find out what line error was generated in. # shift if $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__); my $pkg = shift || scalar caller; my ($pack, $file, $line, $i, @rest, $last_pkg); while (($pack, $file, $line, @rest) = caller ($i++)) { if ($pack eq $pkg) { $last_pkg = $i; } } ($pack, $file, $line) = caller ($last_pkg++); return ($file, $line); } END_OF_FUNC $COMPILE{_generate_fatal} = __LINE__ . <<'END_OF_FUNC'; sub _generate_fatal { # ------------------------------------------------------------------- # Generates a fatal error caused by misuse of AUTOLOAD. # my ($self, $attrib, $param) = @_; my $is_hash = index ($self, 'HASH') != -1; my $pkg = ref $self || $self; my @poss; my @class = @{$pkg . '::ISA'} || (); unshift @class, $pkg; foreach (@class) { my %stach = %{$_ . '::'}; foreach my $routine (keys %stach) { next if $attrib eq $routine; next unless $self; next unless (UNIVERSAL::can($self, $routine)); if (GT::Base->_sndex ($attrib) eq _sndex ($routine)) { push @poss, $routine; } } } # Generate an error message, with possible alternatives and die. my $err_pkg = $is_hash ? (defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg) : $pkg; my ($call_pkg, $file, $line) = caller(1); my $msg = " Perhaps you ment to call " . join (", or " => @poss) . ".\n" if (@poss); $msg = defined $msg ? $msg : ''; die "$err_pkg ($$): Unknown method '$attrib' called at $file line $line.\n$msg"; } END_OF_FUNC $COMPILE{_sndex} = __LINE__ . <<'END_OF_FUNC'; sub _sndex { # ------------------------------------------------------- # Do a soundex lookup to suggest alternate methods the person # might have wanted. # my $self = shift; local $_ = shift; my $search_sound = uc; $search_sound =~ tr/A-Z//cd; if ($search_sound eq '') { $search_sound = 0 } else { my $f = substr ($search_sound, 0, 1); $search_sound =~ tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/; my $fc = substr ($search_sound, 0, 1); $search_sound =~ s/^$fc+//; $search_sound =~ tr///cs; $search_sound =~ tr/0//d; $search_sound = $f . $search_sound . '000'; $search_sound = substr ($search_sound, 0, 4); } return $search_sound; } END_OF_FUNC 1; __END__ =head1 NAME GT::Base - Common base module to be inherited by all classes. =head1 SYNOPSIS use GT::Base; use vars qw/@ISA $ATTRIBS $ERRORS/ @ISA = qw/GT::Base/; $ATTRIBS = { accessor => default, accessor2 => default, }; $ERRORS = { BADARGS => "Invalid argument: %s passed to subroutine: %s", }; =head1 DESCRIPTION GT::Base is a base class that is used to provide common error handling, debugging, creators and accessor methods. To use GT::Base, simply make your module inherit from GT::Base. That will provide the following functionality: =head2 Debugging Two new methods are available for debugging: $self->debug($msg, [DEBUG_LEVEL]); This will send a $msg to STDERR if the current debug level is greater then the debug level passed in (defaults to 1). $self->debug_level(DEBUG_LEVEL); Class->debug_level(DEBUG_LEVEL); You can call debug_level() to set or get the debug level. It can be set per object by calling it as an object method, or class wide which will initilize all new objects with that debug level (only if using the built in creator). The debugging uses a package variable: $Class::DEBUG = 0; and assumes it exists. =head2 Error Handling Your object can now generate errors using the method: $self->error(CODE, LEVEL, [args]); CODE should be a key to a hash of error codes to user readable error messages. This hash should be stored in $ERRORS which is defined in your pacakge, or the package named in $ERROR_MESSAGE. LEVEL should be either 'FATAL' or 'WARN'. If not specified it defaults to FATAL. If it's a fatal error, the program will print the message to STDERR and die. args can be used to format the error message. For instance, you can defined commonly used errors like: CANTOPEN => "Unable to open file: %s. Reason: %s" in your $ERRORS hash. Then you can call error like: open FILE, "somefile.txt" or return $self->error(CANTOPEN => FATAL => "somefile.txt", "$!"); The error handler will format your message using sprintf(), so all regular printf formatting strings are allowed. Since errors are kept within an array, too many errors can pose a memory problem. To clear the error stack simply call: $self->clear_errors(); =head2 Error Trapping You can specify at run time to trap errors. $self->catch_errors(\&code_ref); which sets a $SIG{__DIE__} handler. Any fatal errors that occur, will run your function. The function will not be run if the fatal was thrown inside of an eval though. =head2 Stack Trace You can print out a stack trace at any time by using: $self->stack_trace(1); Class->stack_trace(1); If you pass in 1, the stack trace will be returned as a string, otherwise it will be printed to STDOUT. =head2 Accessor Methods Using GT::Base automatically provides accessor methods for all your attributes. By specifying: $ATTRIBS = { attrib => 'default', ... }; in your package, you can now call: my $val = $obj->attrib(); $obj->attrib($set_val); to set and retrieve the attributes for that value. Note: This uses AUTOLOAD, so if you implement AUTOLOAD in your package, you must have it fall back to GT::Base::AUTOLOAD if it fails. This can be done with: AUTOLOAD { ... goto >::Base::AUTOLOAD; } which will pass all arguments as well. =head2 Parameter Parsing GT::Base also provides a method to parse parameters. In your methods you can do: my $self = shift; my $parm = $self->common_param(@_); This will convert any of a hash reference, hash or CGI object into a hash reference. =head1 COPYRIGHT Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved. http://www.gossamer-threads.com/ =head1 VERSION Revision: $Id: Base.pm,v 1.108 2002/05/31 19:15:16 jagerman Exp $ =cut private/lib/GT/Date.pm0100644000076400010020000010712507457653706013355 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::Date # Author : Aki Mimoto # $Id: Date.pm,v 1.67 2002/04/18 23:33:26 alex Exp $ # # Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: # Generic date manipulation routines. Exports functions to use. # package GT::Date; # =============================================================== # This package implements the date handling routines. # The default date format is yyyy-mm-dd as in 1999-12-25. To change the # format, edit $DATE_FMT and use any of the following: # # yyyy - four digit year as in 1999 # yy - two digit year as in 99 # y - two digit year without leading 0 # mmmm - long month name as in January # mmm - short month name as in Jan # mm - numerical month name as in 01 # m - same as mm, but without leading 0's for months 1-9 # dddd - long day name as in Sunday # ddd - short day name as in Sun # dd - numerical date # d - numerical date without leading 0 # HH - numerical hours (24 hour time) # H - numerical hours without leading 0 (24 hour time) # hh - numerical hours (12 hour time) # h - numerical hours without leading 0 (12 hour time) # MM - numerical minutes # M - numerical minutes without leading 0 # ss - numerical seconds # s - numerical seconds without leading 0 # tt - AM or PM (use with 12 hour time) # o - + or - gm offset # # Common formats: # %yyyy%-%mm%-%dd% 1999-12-25 # %dd%-%mmm%-%yyyy% 12-Dec-1999 # %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999 # %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999 # # RFC822 # %ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o% Sat, 12, Dec 1999 21:32:02 -0800 # # MySQL # %yyyy%-%mm%-%dd% %HH%:%MM%:%ss% 1999-03-25 21:32:02 # use strict; use vars qw/$GM_OFFSET @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DATE_FMT $RANGE_CHECK $VERSION $AUTOLOAD $LANGUAGE $OFFSET %GMTTIME $LOUD/; use GT::Cache; use Exporter; use GT::AutoLoader; $VERSION = sprintf "%d.%03d", q$Revision: 1.67 $ =~ /(\d+)\.(\d+)/; @ISA = qw/Exporter/; @EXPORT_OK = qw/timelocal timegm date_is_valid date_is_greater date_is_smaller date_get date_get_gm date_gmt_offset date_comp date_diff date_add date_add_gm date_sub date_sub_gm date_http_gmt date_set_month date_set_month_short date_set_days date_set_days_short date_set_format date_get_format date_transform parse_format format_date /; %EXPORT_TAGS = ( all => \@EXPORT_OK, timelocal => [ qw(timelocal timegm) ] ); # Module Options. $DATE_FMT = "%yyyy%-%mm%-%dd%"; $OFFSET = 0 * 3600; $RANGE_CHECK = 0; $LOUD = 0; $LANGUAGE = { 'month_names' => [qw/January February March April May June July August September October November December/], 'day_names' => [qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/], 'short_month_names' => [qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/], 'short_day_names' => [qw/Sun Mon Tue Wed Thu Fri Sat/] }; # Time strings to GM offset in minutes %GMTTIME = ( GMT => 0, BST => 60, IST => 60, WET => 0, WEST => 60, CET => 60, CEST => 120, EET => 120, EEST => 180, MSK => 180, MSD => 240, AST => -240, ADT => -180, EST => -300, EDT => -240, ET => -300, CST => -360, CDT => -300, CT => -360, MST => -420, MDT => -360, MT => -420, PST => -480, PDT => -420, PT => -480, HST => -600, AKST => -540, AKDT => -480, WST => 480, ); # Set up our Cache objects. use vars qw( @MONTHS %MONTHS @DAYS %DAYS @MONTHS_SH %MONTHS_SH @DAYS_SH %DAYS_SH %MONTH_HASH %DATE_TO_TM %DATE_TRANS %MONTH_YEAR ); tie %DATE_TO_TM, 'GT::Cache', 500, \&_date_str_to_time; tie %DATE_TRANS, 'GT::Cache', 500, \&_transform; tie %MONTH_YEAR, 'GT::Cache', 500, \&_calc_my; # Constants in calculating the time array => unix time. use constants SEC => 1, MIN => 60, # 60 * SEC HOUR => 3600, # 60 * MIN DAY => 86400; # 24 * HOUR build_lang(); sub build_lang { # ---------------------------------------------------- # Build vars to use internally. # @MONTHS = @{$LANGUAGE->{month_names}}; my $i = 0; %MONTHS = map { $_ => $i++ } @MONTHS; @DAYS = @{$LANGUAGE->{day_names}}; $i = 0; %DAYS = map { $_ => $i++ } @DAYS; @MONTHS_SH = @{$LANGUAGE->{short_month_names}}; $i = 0; %MONTHS_SH = map { $_ => $i++ } @MONTHS_SH; @DAYS_SH = @{$LANGUAGE->{short_day_names}}; $i = 0; %DAYS_SH = map { $_ => $i++ } @DAYS_SH; %MONTH_HASH = map { ( $MONTHS[$_] => $_, $MONTHS_SH[$_] => $_ ) } ( 0..11 ); } $COMPILE{date_set_format} = __LINE__ . <<'END_OF_SUB'; sub date_set_format { # ---------------------------------------------------- # Set the date format to use, make sure to clear caches. # $DATE_FMT = shift; %DATE_TO_TM = (); } END_OF_SUB $COMPILE{date_get_format} = __LINE__ . <<'END_OF_SUB'; sub date_get_format { # ---------------------------------------------------- # Set the date format to use. # return $DATE_FMT; } END_OF_SUB $COMPILE{date_set_month} = __LINE__ . <<'END_OF_SUB'; sub date_set_month { # ---------------------------------------------------- # Set the language. # my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_; $LANGUAGE->{month_names} = $lang; build_lang(); } END_OF_SUB $COMPILE{date_set_month_short} = __LINE__ . <<'END_OF_SUB'; sub date_set_month_short { # ---------------------------------------------------- # Set the language. # my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_; $LANGUAGE->{short_month_names} = $lang; build_lang(); } END_OF_SUB $COMPILE{date_set_days} = __LINE__ . <<'END_OF_SUB'; sub date_set_days { # ---------------------------------------------------- # Set the language. # my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_; $LANGUAGE->{day_names} = $lang; build_lang(); } END_OF_SUB $COMPILE{date_set_days_short} = __LINE__ . <<'END_OF_SUB'; sub date_set_days_short { # ---------------------------------------------------- # Set the language. # my $lang = ref $_[0] eq 'ARRAY' ? $_[0] : \@_; $LANGUAGE->{short_day_names} = $lang; build_lang(); } END_OF_SUB $COMPILE{date_is_valid} = __LINE__ . <<'END_OF_SUB'; sub date_is_valid { # ---------------------------------------------------- # Check whether a string is a valid date. # my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); return $DATE_TO_TM{$key}; } END_OF_SUB $COMPILE{date_is_greater} = __LINE__ . <<'END_OF_SUB'; sub date_is_greater { # ---------------------------------------------------- # Returns 1 if the first date is larger then the second. # (date_comp(@_) == 1) ? return 1 : return undef; } END_OF_SUB $COMPILE{date_is_smaller} = __LINE__ . <<'END_OF_SUB'; sub date_is_smaller { # ---------------------------------------------------- # Returns 1 if the first date is smaller then the second. # (date_comp(@_) == -1) ? return 1 : return undef; } END_OF_SUB $COMPILE{date_get} = __LINE__ . <<'END_OF_SUB'; sub date_get { # ---------------------------------------------------- # Return today's date or a date from a time() that you # pass in. Optionally takes a second argument as a # date format to return the result in. Any offset will # be added to the date as required. # my $time = shift || time; $time += $OFFSET if $OFFSET; my $fmt = shift || $DATE_FMT; my @date = localtime($time); return format_date(\@date, $fmt); } END_OF_SUB $COMPILE{date_get_gm} = __LINE__ . <<'END_OF_SUB'; sub date_get_gm { # ---------------------------------------------------- # Return today's date or a date from a time() that you # pass in. Optionally takes a second argument as a # date format to return the result in. # my $time = shift || (time + $OFFSET); my $fmt = shift || $DATE_FMT; my @date = gmtime($time); return format_date(\@date, $fmt); } END_OF_SUB $COMPILE{date_comp} = __LINE__ . <<'END_OF_SUB'; sub date_comp { # ---------------------------------------------------- # Equivalant to $date1 <=> $date2 # my $key1 = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); my $key2 = join("\0", $_[1], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); return $DATE_TO_TM{$key1} <=> $DATE_TO_TM{$key2}; } END_OF_SUB $COMPILE{date_diff} = __LINE__ . <<'END_OF_SUB'; sub date_diff { # ---------------------------------------------------- # Return number of days difference between two dates. # my $key1 = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); my $key2 = join("\0", $_[1], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); return int (($DATE_TO_TM{$key1} - $DATE_TO_TM{$key2}) / DAY); } END_OF_SUB $COMPILE{date_add} = __LINE__ . <<'END_OF_SUB'; sub date_add { # ---------------------------------------------------- # Returns argument a +- x days. # my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); my @date = localtime($DATE_TO_TM{$key} + $_[1] * DAY); return format_date(\@date); } END_OF_SUB $COMPILE{date_add_gm} = __LINE__ . <<'END_OF_SUB'; sub date_add_gm { # ---------------------------------------------------- # Returns argument a +- x days. # my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); my @date = gmtime($DATE_TO_TM{$key} + $_[1] * DAY); return format_date(\@date); } END_OF_SUB $COMPILE{date_sub} = __LINE__ . <<'END_OF_SUB'; sub date_sub { # ---------------------------------------------------- # Returns argument - days. # my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); my @date = localtime($DATE_TO_TM{$key} - $_[1] * DAY); return format_date(\@date); } END_OF_SUB $COMPILE{date_sub_gm} = __LINE__ . <<'END_OF_SUB'; sub date_sub_gm { # ---------------------------------------------------- # Returns argument - days. # my $key = join("\0", $_[0], @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); my @date = gmtime($DATE_TO_TM{$key} - $_[1] * DAY); return format_date(\@date); } END_OF_SUB $COMPILE{date_transform} = __LINE__ . <<'END_OF_SUB'; sub date_transform { # ---------------------------------------------------- # Takes a date, followed by orig format and transforms to # a new format. # my ($date, $orig, $new) = @_; my $key = join("\0", $date, $orig, $new, @MONTHS, @DAYS, @MONTHS_SH, @DAYS_SH); return $DATE_TRANS{$key}; } END_OF_SUB $COMPILE{format_date} = __LINE__ . <<'END_OF_SUB'; sub format_date { # ---------------------------------------------------- # Takes an array from localtime or equiv and a date format # and returns date. # my $date = shift; my $fmt = shift || $DATE_FMT; my (@real, $time); # Make sure we have all the info. for (0 .. $#{$date}) { if (! defined $date->[$_]) { if (!@real) { $time = timelocal(@{$date}); @real = localtime($time); } $date->[$_] = $real[$_]; } } my ($sec, $min, $hour, $day, $mon, $year, $dwk) = @{$date}; my $twelve_hour = $hour == 0 ? 12 : $hour > 12 ? $hour - 12 : $hour; my $vals = { ss => sprintf ("%02d", $sec), s => $sec, MM => sprintf ("%02d", $min), M => $min, HH => sprintf ("%02d", $hour), H => $hour, hh => sprintf ("%02d", $twelve_hour), h => $twelve_hour, tt => ($hour >= 12 ? "PM" : "AM"), dd => sprintf ("%02d", $day), d => $day, mm => sprintf ("%02d", $mon + 1), m => $mon + 1, mmmm => defined $MONTHS[$mon] ? $MONTHS[$mon] : '', mmm => defined $MONTHS_SH[$mon] ? $MONTHS_SH[$mon] : '', dddd => defined $DAYS[$dwk] ? $DAYS[$dwk] : '', ddd => defined $DAYS_SH[$dwk] ? $DAYS_SH[$dwk] : '', yyyy => $year + 1900, yy => sprintf ("%02d", $year % 100), y => $year % 100, o => sub { my $offset = date_gmt_offset(); return sprintf ("%+05d", int($offset / 3600) * 100 + int(($offset % 3600) /60)) } }; $fmt =~ s/%([^%]+)%/exists $vals->{$1} ? (ref($vals->{$1}) eq 'CODE') ? $vals->{$1}->() : $vals->{$1} : ''/eg; return $fmt; } END_OF_SUB $COMPILE{parse_format} = __LINE__ . <<'END_OF_SUB'; sub parse_format { # ---------------------------------------------------- # Takes a string and a date format and returns an array # ref of the first 7 arguments returned by localtime(). # my $date = shift; my $fmt = shift || $DATE_FMT; return unless ($date); my $pos = 0; my ($sec, $min, $hour, $pm, $day, $mon, $year, $dwk, $before, $type, $adjust, $leading, $h24); while ($fmt =~ /([^%]*?)%([^%]+)%/g) { $leading = $1; $type = $2; CASE: { # yyyy - four digit year as in 1999 ($type eq 'yyyy' and !defined $year) and do { $date =~ s/^\Q$leading\E(\d{4})// or return; $year = int( int( $1 ) - 1900); last CASE; }; # yy - two digit year as in 99 ($type eq 'yy' and !defined $year) and do { $date =~ s/^\Q$leading\E(\d{2})// or return; $year = int $1; if ( $year < 69 ) { # 20xx $year += 2000; } else { # 19xx $year += 1900; } $year = $year - 1900; last CASE; }; # y - two digit year without leading 0 ($type eq 'y' and !defined $year) and do { $date =~ s/^\Q$leading\E(\d?\d)// or return; $year = int $1; $year = 2000 + $year if $year < 40; $year = $year - 1900; last CASE; }; # mmmm - long month name as in January ($type eq 'mmmm' and !defined $mon) and do { my $val; for ( keys %MONTHS ) { if ( index( $date, "$leading$_" ) == 0 ) { $val = $_; substr( $date, 0, length( $leading.$_ ) ) = ''; last; } } $val or return; $mon = int $MONTHS{$val}; last CASE; }; # mmm - short month name as in Jan ($type eq 'mmm' and !defined $mon) and do { my $val; for ( keys %MONTHS_SH ) { if ( index( $date, "$leading$_" ) == 0 ) { $val = $_; substr( $date, 0, length( $leading.$_ ) ) = ''; last; } } $val or return; $mon = int $MONTHS_SH{$val}; last CASE; }; # mm - numerical month name as in 01 ($type eq 'mm' and !defined $mon) and do { $date =~ s/^\Q$leading\E(\d{2})// or return; $mon = int( $1 - 1 ); last CASE; }; # m - same as mm, but without leading 0's for months 1-9 ($type eq 'm' and !defined $mon) and do { $date =~ s/^\Q$leading\E(\d?\d)// or return; $mon = int( $1 - 1 ); last CASE; }; # dddd - long day name as in Sunday ($type eq 'dddd' and !defined $dwk) and do { my $val; for ( keys %DAYS ) { if ( index( $date, "$leading$_" ) == 0 ) { $val = $_; substr( $date, 0, length( $leading.$_ ) ) = ''; last; } } $val or return; $dwk = int $DAYS{$val}; last CASE; }; # ddd - short day name as in Sun ($type eq 'ddd' and !defined $dwk) and do { my $val; for ( keys %DAYS_SH ) { if ( index( $date, "$leading$_" ) == 0 ) { $val = $_; substr( $date, 0, length( $leading.$_ ) ) = ''; last; } } $val or return; $dwk = int $DAYS_SH{$val}; last CASE; }; # dd - numerical date ($type eq 'dd' and !defined $day) and do { $date =~ s/^\Q$leading\E(\d{2})// or return; $day = int $1; last CASE; }; # d - numerical date without leading 0 ($type eq 'd' and !defined $day) and do { $date =~ s/^\Q$leading\E(\d?\d)// or return; $day = int $1; last CASE; }; # HH - numerical hours (24 hour time) ($type eq 'HH' and !defined $hour) and do { $date =~ s/^\Q$leading\E(\d{2})// or return; $hour = int $1; $h24 = 1; last CASE; }; # H - numerical hours without leading 0 (24 hour time) ($type eq 'H' and !defined $hour) and do { $date =~ s/^\Q$leading\E(\d?\d)// or return; $hour = int $1; $h24 = 1; last CASE; }; # hh - numerical hours (12 hour time) ($type eq 'hh' and !defined $hour) and do { $date =~ s/^\Q$leading\E(\d{2})// or return; $hour = int $1; last CASE; }; # h - numerical hours without leading 0 (12 hour time) ($type eq 'h' and !defined $hour) and do { $date =~ s/^\Q$leading\E(\d?\d)// or return; $hour = int $1; last CASE; }; # MM - numerical minutes ($type eq 'MM' and !defined $min) and do { $date =~ s/^\Q$leading\E(\d{2})// or return; $min = int $1; last CASE; }; # M - numerical minutes without leading 0 ($type eq 'M' and !defined $min) and do { $date =~ s/^\Q$leading\E(\d?\d)// or return; $min = int $1; last CASE; }; # ss - numerical seconds ($type eq 'ss' and !defined $sec) and do { $date =~ s/^\Q$leading\E(\d{2})// or return; $sec = int $1; last CASE; }; # s - numerical seconds without leading 0 ($type eq 's' and !defined $sec) and do { $date =~ s/^\Q$leading\E(\d?\d)// or return; $sec = int $1; last CASE; }; # tt - AM or PM (use with 12 hour time) ($type eq 'tt' and !defined $pm) and do { $date =~ s/^\Q$leading\E([aApP][mM])// or return; $pm = uc( $1 ) eq 'PM'; last CASE; }; # o - + or - gm offset ($type eq 'o' and !defined $adjust) and do { $date =~ s/^\Q$leading\E((?:\w{1,4})|(?:[+\-]?\d{3,4}))// or return; $adjust = $1; last CASE; }; return; } } defined $sec or ($sec = 0); defined $min or ($min = 0); defined $hour or ($hour = 0); if ($pm and $hour < 12) { $hour += 12; } elsif (!$pm and !$h24 and $hour == 12) { $hour = 0; } if (defined $day && defined $mon && defined $year) { if (defined $adjust) { my $minutes; if ($adjust =~ /^([+\-]?)(\d?\d)(\d\d)$/) { my $neg = $1 || '+'; if ($neg eq '-') { $minutes -= ($2 * 60) + $3; } else { $minutes = ($2 * 60) + $3; } } elsif (exists $GMTTIME{$adjust}) { $minutes = $GMTTIME{$adjust}; } if (defined $minutes) { my $time = timelocal($sec, $min, $hour, $day, $mon, $year, $dwk); my $gm_offset = date_gmt_offset(); my $tm_offset = $minutes * 60; $time = $time + ($gm_offset - $tm_offset); return [(localtime($time))[0..6]]; } } return [$sec, $min, $hour, $day, $mon, $year, $dwk]; } return; } END_OF_SUB $COMPILE{date_gmt_offset} = __LINE__ . <<'END_OF_SUB'; sub date_gmt_offset { # ---------------------------------------------------- # Returns the offset from local to gmtime in seconds. # This can be a negative number. # defined($GM_OFFSET) and return $GM_OFFSET; $GM_OFFSET = timegm(localtime) - timelocal(localtime); return $GM_OFFSET; } END_OF_SUB $COMPILE{timelocal} = __LINE__ . <<'END_OF_SUB'; sub timelocal { # ------------------------------------------------------------------- # Returns unix time from a timelocal array. # my @date = @_ ? (ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_) : localtime; my $time = timegm (@date); my $orig = $time; my @lt = localtime ($time); my @gt = gmtime ($time); if ($time < DAY and ($lt[5] >= 70 or $gt[5] >= 70 )) { $orig += DAY; @lt = localtime($orig); @gt = gmtime($orig); } my $tzsec = ($gt[1] - $lt[1]) * MIN + ($gt[2] - $lt[2]) * HOUR; if ($lt[5] > $gt[5]) { $tzsec -= DAY; } elsif ($gt[5] > $lt[5]) { $tzsec += DAY; } else { $tzsec += ($gt[7] - $lt[7]) * DAY; } $tzsec += HOUR if($lt[8]); my $ret = $time + $tzsec; my @test = localtime($ret + ($orig - $time)); $ret -= HOUR if $test[2] != $date[2]; return $ret; } END_OF_SUB $COMPILE{timegm} = __LINE__ . <<'END_OF_SUB'; sub timegm { # ------------------------------------------------------------------- # Returns gm unix time based on a timelocal/gmtime array. # my @date = @_ ? (ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_) : gmtime; if ($date[5] > 999) { $date[5] -= 1900; } while ($date[4] < 0) { # If a negative month gets passed in, add 12 months and subtract a year $date[4] += 12; $date[5]--; } while ($date[4] >= 12) { # If a month too large is passed in, subtract 12 months and add a year $date[4] -= 12; $date[5]++; } my $time_str = join "\0", map { defined $_ ? $_ : '' } @date; my $time = $MONTH_YEAR{$time_str}; $time + $date[0] * SEC + $date[1] * MIN + $date[2] * HOUR + ($date[3]-1) * DAY; } END_OF_SUB # ====================================================================== # # PRIVATE FUNCTIONS # # ====================================================================== # $COMPILE{_date_str_to_time} = __LINE__ . <<'END_OF_SUB'; sub _date_str_to_time { # ---------------------------------------------------- # Takes a date string and converts it to a unix time. # return unless (defined $_[0]); my ($date, @lang) = split /\0/, $_[0]; if (@lang != 38) { die "Invalid number of elements passed to _date_str_to_time: " . scalar @lang; } local @MONTHS = @lang[0 .. 11]; local @DAYS = @lang[12 .. 18]; local @MONTHS_SH = @lang[19 .. 30]; local @DAYS_SH = @lang[31 .. 37]; my $time_arr = parse_format($date) or return 0; return timelocal (@$time_arr); } END_OF_SUB $COMPILE{_format_date} = __LINE__ . <<'END_OF_SUB'; sub _format_date { format_date(@_); } END_OF_SUB $COMPILE{_parse_format} = __LINE__ . <<'END_OF_SUB'; sub _parse_format { parse_format(@_) } END_OF_SUB $COMPILE{_parse_gmt_date} = __LINE__ . <<'END_OF_SUB'; sub _parse_gmt_date { # ---------------------------------------------------- # attempts to turn a date string into a unix timestamp # my $in = shift || return timegm ( gmtime() ); my ($sec, $min, $hour, $day, $mon, $year); # Handle + or - increments easily, just calculate current # gmtime, and figure out desired offset and return. if ($in =~ /^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) { my %mult = ( 's' => 1, 'm' => 60, 'h' => 60*60, 'd' => 60*60*24, 'M' => 60*60*24*30, 'y' => 60*60*24*365 ); my $gmtime = timegm( gmtime() ); $gmtime = $gmtime + ($mult{$2} || 1) * $1; return $gmtime; } # Otherwise, we try and build a gmtime array, to pass # to timegm. if ( $in =~ s/(\d+):(\d+)(:(\d+))?\s*(am|pm)?//i ) { ( $hour, $min, $sec ) = ( $1 || 0, $2 ||0, $4 || 0 ); if ( ( $hour < 12 ) and ( lc($5) eq 'pm' ) ) { $hour += 12 } if ( ( $hour == 12 ) and ( lc($5) eq 'am' ) ) { $hour = 0 } } # Try and find either the long month or short month. my $mo_regex = join("|", ( @MONTHS, @MONTHS_SH )); if ($in =~ /($mo_regex)/i ) { my $mostr = $1; $mon = $MONTH_HASH{$mostr}; $in =~ s/(\d+)?(st|nd|th)?\s*$mostr\s*(\d+)(st|nd|th)?//i; if ( $1 > 31 ) { $year = $1; $day = $3; } else { $day = $1 || $3; if ( $day > 31 ) { $year = $day; $day = 0; } } } # Try and get a four digit year. if ($in =~ s/(\d\d\d\d)//) { $year = $1; } # Try and get dd/mm/yy format. if ($in =~ s,(\d+)/(\d+)/(\d+),,o) { $day = $1; $mon = $2; $year = $3; } # If the word equals 'now', then use that. my @local = gmtime(); $local[5] += 1900; $local[4]++; if ($in =~ s/now//) { ($sec, $min, $hour, $day, $mon, $year) = @local[ 0, 1, 2, 3, 4, 5 ]; } else { $day ||= $local[3]; $mon ||= $local[4]; $year ||= $local[5]; if (!defined($hour)) { $hour ||= $local[2]; $min ||= $local[1]; $sec ||= $local[0]; } } # Make sure we have a four digit year. ($year < 99) and ($year += 1900); # Timelocal needs month in same format as localtime (i.e. indexed from 0). return timegm ($sec, $min, $hour, $day, $mon - 1, $year); } END_OF_SUB $COMPILE{_calc_my} = __LINE__ . <<'END_OF_SUB'; sub _calc_my { # ------------------------------------------------------------------- # Calculates the gmtime of the month and year. # my $date = shift; my ($sec, $min, $hour, $day, $mon, $year) = split /\0/, $date; if ($RANGE_CHECK) { ($mon > 11 or $mon < 0) and die "Month '$mon' out of range 0..1"; ($day > 31 or $day < 1) and die "Day '$day' out of range 1..31"; ($hour > 23 or $hour < 0) and die "Hour '$hour' out of range 0..23"; ($min > 59 or $min < 0) and die "Minute '$min' out of range 0..59"; ($sec > 59 or $sec < 0) and die "Second '$sec' out of range 0..59"; } my $guess = $^T; my @guess = gmtime ($guess); my $last = ''; my $count = 0; my $diff = 0; # Calc year offset. while ($diff = $year - $guess[5]) { if ($count++ > 255) { warn "GT::Date - can't handle date: $date\n" if ($LOUD); return 0; } $guess += $diff * (363 * DAY); @guess = gmtime ($guess); if ("@guess" eq $last) { warn "GT::Date - can't handle date: $date\n" if ($LOUD); return 0; } $last = "@guess"; } # Calc month offset. while ($diff = $mon - $guess[4]) { if ($count++ > 255) { warn "GT::Date - can't handle date: $date\n" if ($LOUD); return 0; } $guess += $diff * (27 * DAY); @guess = gmtime ($guess); if ("@guess" eq $last) { warn "GT::Date - can't handle date: $date\n" if ($LOUD); return 0; } $last = "@guess"; } # We only want the month/year aspect. $guess[3]--; $guess -= $guess[0] * SEC + $guess[1] * MIN + $guess[2] * HOUR + $guess[3] * DAY; return $guess; } END_OF_SUB $COMPILE{_transform} = __LINE__ . <<'END_OF_SUB'; sub _transform { # ---------------------------------------------------- # Transforms a date from one format to another, not called # directly, accessed through cache. # my $key = shift; my ($date, $orig, $new, @lang) = split /\0/, $key; if (@lang != 38) { die "Invalid number of elements passed to _date_str_to_time: " . scalar @lang; } local @MONTHS = @lang[0 .. 11]; local @DAYS = @lang[12 .. 18]; local @MONTHS_SH = @lang[19 .. 30]; local @DAYS_SH = @lang[31 .. 37]; my $time = parse_format ($date, $orig) or return; return format_date ($time, $new); } END_OF_SUB 1; __END__ =head1 NAME GT::Date - Common date parsing and manipulation routines =head1 SYNOPSIS use GT::Date qw/:all/; my $date = date_get(); my $next_week = date_add($date, 7); my $is_bigger = date_is_greater($date, $next_week); =head1 DESCRIPTION GT::Date provides several functions useful in parsing dates, and doing date manipulation. Under the hood, it uses Time::Local code to transform a date into seconds for comparison and mathematical operations. It also uses L to store most of the complex work. No functions are exported by default. You can either specify the functions you need in use, or use the tags ':all' or ':timelocal'. All will give you all functions, and timelocal will give you functions found in Time::Local. GT::Date uses a package global $DATE_FMT which specifies the format that dates should be returned in. You can change this using the date_set_format() function. =head2 date_is_valid Returns 1 if the argument passed in is a valid date. It must first be in the current date format, and then be a valid date. =head2 date_is_greater Returns 1 if argument 1 is greater then argument 2, otherwise 0. =head2 date_is_smaller Returns 1 if argument 1 is smaller then argument 2, otherwise 0. =head2 date_get date_get_gm Called with no arguments, returns the current date based on system time. You can specify the date you want by passing in the seconds since epoch (output of time()). =head2 date_comp Equivalent to arg1 <=> arg2. =head2 date_diff Returns number of days difference between arg1 - arg2. =head2 date_add date_add_gm Returns date derived from arg1 + arg2, where the second argument can be either a date or number of days. =head2 date_sub date_sub_gm Returns date derived from arg1 - arg2, where the second argument can be either a date or number of days. =head2 timegm Takes the returned array from gmtime() and returns a unix time stamp. =head2 timlocal Takes the array returned by localtime() can returns a unix time stamp. =head2 parse_format Takes a string and a date format and returns an array ref of the first 7 arguments returned by localtime(). =head2 format_date Takes a localtime array, and a format string and returns a string of the parsed format. =head2 Setting date format You can use date_set_format to change the format. You pass in a format string. It is made up of: %yyyy% four digit year as in 1999 %yy% two digit year as in 99 %y% two digit year without leading 0 %mmmm% long month name as in January %mmm% short month name as in Jan %mm% numerical month name as in 01 %m% numerical month name without leading 0 as in 1 %dddd% long day name as in Sunday %ddd% short day name as in Sun %dd% numerical date %d% numerical date without leading 0 %HH% two digit hour, 24 hour time %H% one or two digit hour, 24 hour time %hh% two digit hour, 12 hour time. 0 becomes 12. %h% one or two digit hour, 12 hour time. 0 becomes 12. %MM% two digit minute %M% one or two digit minute (when would someone ever WANT this?) %ss% two digit second %s% one ot two digit second (when would someone ever WANT this?) %tt% AM or PM (use with 12 hour time) %o% + or - GMT offset Common formats include: %yyyy%-%mm%-%dd% 1999-12-25 %dd%-%mmm%-%yyyy% 12-Dec-1999 %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999 %ddd% %mmm% %dd% %yyyy% Sat Dec 12 1999 or RFC822 mime mail format: %ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o% Sat, 12, Dec 1999 21:32:02 -0800 or MySQL format: %yyyy%-%mm%-%dd% %HH%:%MM%:%ss% 1999-03-25 21:32:02 The language used for month names and day names can be changed with date_set_month(), date_set_days(), date_set_days_short() and date_set_month_short(). =head2 Transforming between date formats. You can transform a date from one format to another with: date_transform ($date, $orig_fmt, $new_fmt); where $orig_fmt and $new_fmt are date format strings described above. =head2 Getting the GM offset. You can get the number of seconds between the system time and GM time using: my $time = date_gmt_offset(); So if you are in Pacific time, it would return 25200 seconds (-0700 time zone). =head1 EXAMPLES Get todays date, the default format unless specified is yyyy-mm-dd. print date_get(); 2000-12-31 Get todays date in a different format: date_set_format('%ddd% %mmm% %dd% %yyyy%'); print date_get(); Sat Dec 31 2000 Get the date from 1 week ago. # Long way my $date1 = date_get(); my $date2 = date_sub($date1, 7); or # Can pass in unix timestamp of date we want. my $date = date_get (time - (7 * 86400)); Compare two dates. my $halloween = '2000-10-31'; my $christmas = '2000-12-25'; if (date_is_smaller($halloween, $christmas)) { print "Halloween comes before christmas!"; } if (date_is_greater($christmas, $halloween)) { print "Yup, christmas comes after halloween."; } my @dates = ($halloween, $christmas); print "Dates in order: ", sort date_comp @dates; =head1 COPYRIGHT Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. http://www.gossamer-threads.com/ =head1 VERSION Revision: $Id: Date.pm,v 1.67 2002/04/18 23:33:26 alex Exp $ =cut private/lib/GT/Dumper.pm0100644000076400010020000002016207453207671013717 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::Dumper # Author : Scott Beck # $Id: Dumper.pm,v 1.30 2002/04/05 02:45:13 jagerman Exp $ # # Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: # Implements a simple data dumper, useful for converting complex # data structures to strings. # package GT::Dumper; # =============================================================== use strict; use vars qw /$DEBUG $ATTRIBS $VERSION @EXPORT @ISA $TAB $EOL/; use GT::Base; use Exporter; $TAB = ' '; $EOL = "\n"; $VERSION = sprintf "%d.%03d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/; $ATTRIBS = { var => undef, data => undef, sort => undef, order => undef, compress => undef, structure => undef }; @EXPORT = qw(Dumper); @ISA = qw(Exporter GT::Base); sub Dumper { # ----------------------------------------------------------- # Dumper acts similar to Dumper in Data::Dumper when called as a # class method. If called as a instance method it assumes you # have set the options for the dump and does not change them. # It only takes a single argument - the variable to dump. # my $self; if (@_ == 1) { if (ref $_[0] eq 'GT::Dumper') { $self = shift; } else { $self = GT::Dumper->new ( var => '$VAR', data => shift ); } } elsif (@_ == 2) { if ($_[0] eq 'GT::Dumper') { $self = GT::Dumper->new ( var => '$VAR', data => $_[1] ); } else { $self = shift; $self->{data} = shift; $self->{var} ||= '$VAR'; } } else { die "Bad args to Dumper"; } return $self->dump; } sub dump { # ----------------------------------------------------------- # my $dump = $class->dump (%opts); # -------------------------------- # Returns the data structure specified in %opts flatened. # %opts is optional if you have created an object with the # options. # my $this = shift; # See if options were passed in my $self; if (!ref $this) { $self = $this->new (@_); } elsif (@_ > 0) { $self = $this; $self->init (@_); } else { $self = $this; } my $level = 0; my $ret; $ret .= "$self->{var} = " unless defined $self->{var} and $self->{var} eq ''; $self->_dump_value ($level + 1, $self->{data}, \$ret); $ret .= ';'.$EOL unless $self->{structure}; return $ret ? $ret : 1; } sub dump_structure { my ($self, $data) = @_; return $self->dump(var => '', structure => 1, data => $data); } sub _dump_value { # ----------------------------------------------------------- # Internal method to decide what to dump. # my ($self, $level, $val, $ret, $n) = @_; my $was; if (ref $val and $val =~ /=/) { $self->_dump_obj ($level + 1, $val, $ret) } elsif (ref $val eq 'HASH') { $self->_dump_hash ($level + 1, $val, $ret) } elsif (ref $val eq 'ARRAY') { $self->_dump_array ($level + 1, $val, $ret) } elsif (ref $val eq 'SCALAR' or ref $val eq 'REF' or ref $val eq 'LVALUE') { $self->_dump_scalar ($level + 1, $val, $ret) } else { $val = _escape ($val); $$ret .= $val; } return 1; } sub _dump_scalar { # ----------------------------------------------------------- # Dump a scalar reference. # my ($self, $level, $val, $ret, $n) = @_; my $v = $$val; $$ret .= '\\'; $self->_dump_value($level + 1, $v, $ret, 1); return 1; } sub _dump_hash { # ----------------------------------------------------------- # Internal method to for through a hash and dump it. # my ($self, $level, $hash_ref, $ret) = @_; $$ret .= '{'; my $lines; if ($self->{sort}) { for (sort { ref ($self->{order}) eq 'CODE' ? $self->{order}->($a, $b, $hash_ref->{$a}, $hash_ref->{$b}) : $a cmp $b } keys %{$hash_ref}) { $$ret .= "," if $lines++; $$ret .= $EOL.($TAB x ($level / 2)) unless $self->{compress}; my $key = _escape($_); $$ret .= $self->{compress} ? "$key," : "$key => "; $self->_dump_value ($level + 1, $hash_ref->{$_}, $ret, 1); } } else { for (keys %{$hash_ref}) { $$ret .= "," if $lines++; $$ret .= $EOL.($TAB x ($level / 2)) unless $self->{compress}; my $key = _escape($_); $$ret .= $self->{compress} ? "$key," : "$key => "; $self->_dump_value ($level + 1, $hash_ref->{$_}, $ret, 1); } } $$ret .= $EOL if $lines and not $self->{compress}; $$ret .= ($lines and not $self->{compress}) ? (($TAB x (($level - 1) / 2)) . "}") : "}"; return 1; } sub _dump_array { # ----------------------------------------------------------- # Internal method to for through an array and dump it. # my ($self, $level, $array_ref, $ret) = @_; $$ret .= "["; my $lines; for (@{$array_ref}) { $$ret .= "," if $lines++; $$ret .= $EOL.($TAB x ($level / 2)) unless $self->{compress}; $self->_dump_value ($level + 1, $_, $ret, 1); } $$ret .= ($lines and not $self->{compress}) ? $EOL.(($TAB x (($level - 1) / 2)) . "]") : "]"; return 1; } sub _dump_obj { # ----------------------------------------------------------- # Internal method to dump an object. # my ($self, $level, $obj, $ret) = @_; my $class = ref $obj; $$ret .= "bless("; $$ret .= $EOL.($TAB x ($level / 2)) unless $self->{compress}; if ($obj =~ /ARRAY\(/) { $self->_dump_array ($level + 2, \@{$obj}, $ret) } elsif ($obj =~ /HASH\(/) { $self->_dump_hash ($level + 2, \%{$obj}, $ret) } elsif ($obj =~ /SCALAR\(/ or $obj =~ /REF\(/ or $obj =~ /LVALUE\(/) { $self->_dump_value ($level + 2, $$obj, $ret) } $$ret .= ","; $$ret .= $EOL.($TAB x ($level / 2)) unless $self->{compress}; $$ret .= _escape($class); $$ret .= $EOL.($TAB x (($level - 1) / 2)) unless $self->{compress}; $$ret .= ")"; return 1; } sub _escape { # ----------------------------------------------------------- # Internal method to escape a dumped value. my ($val) = @_; defined ($val) or return 'undef'; $val =~ s/('|\\(?=['\\]|$))/\\$1/g; return "'$val'"; } 1; __END__ =head1 NAME GT::Dumper - Implements a simple data dumper. =head1 SYNOPSIS use GT::Dumper; print Dumper($complex_var); print GT::Dumper->dump ( var => '$MYVAR', data => $complex_var); =head1 DESCRIPTION GT::Dumper by default exports a method Dumper() which will behave similar to Data::Dumper's Dumper(). It differs in that it will only take a single argument, and the variable dumped will be $VAR instead of $VAR1. Also, to provide easier control to change the variable name that gets dumped, you can use: GT::Dumper->dump ( var => string, data => yourdata ); and the dump will start with string = instead of $VAR = . =head1 EXAMPLE use GT::Dumper; my %foo; my @bar = (1, 2, 3); $foo{alpha} = \@bar; $foo{beta} = 'a string'; print Dumper(\%foo); This will print: $VAR = { 'beta' => 'a string', 'alpha' => [ '1', '2', '3', ], }; You may specify a blank variable name ('') and the variable and = sign will be omitted from the output. The "compress" option can be used to eliminate all whitespace. =head1 COPYRIGHT Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved. http://www.gossamer-threads.com/ =head1 VERSION Revision: $Id: Dumper.pm,v 1.30 2002/04/05 02:45:13 jagerman Exp $ =cut private/lib/GT/MD5.pm0100644000076400010020000002777107453737207013070 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::MD5 # Author: Scott Beck (see pod for details) # $Id: MD5.pm,v 1.17 2002/04/07 03:35:35 jagerman Exp $ # # Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. # See bottom for addition Copyrights. # ================================================================== # # Description: This is an implementation of the MD5 algorithm in perl. # package GT::MD5; # ================================================================== use strict; use vars qw($VERSION @ISA @EXPORTER @EXPORT_OK $DATA); @EXPORT_OK = qw(md5 md5_hex md5_base64); @ISA = qw(Exporter); $VERSION = sprintf "%d.%03d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/; $DATA = <<'END_OF_MODULE'; use integer; # I-Vektor sub A() { 0x67_45_23_01 } sub B() { 0xef_cd_ab_89 } sub C() { 0x98_ba_dc_fe } sub D() { 0x10_32_54_76 } # for internal use sub MAX() { 0xFFFFFFFF } @GT::MD5::DATA = split "\n", q| FF,$a,$b,$c,$d,$_[4],7,0xd76aa478,/* 1 */ FF,$d,$a,$b,$c,$_[5],12,0xe8c7b756,/* 2 */ FF,$c,$d,$a,$b,$_[6],17,0x242070db,/* 3 */ FF,$b,$c,$d,$a,$_[7],22,0xc1bdceee,/* 4 */ FF,$a,$b,$c,$d,$_[8],7,0xf57c0faf,/* 5 */ FF,$d,$a,$b,$c,$_[9],12,0x4787c62a,/* 6 */ FF,$c,$d,$a,$b,$_[10],17,0xa8304613,/* 7 */ FF,$b,$c,$d,$a,$_[11],22,0xfd469501,/* 8 */ FF,$a,$b,$c,$d,$_[12],7,0x698098d8,/* 9 */ FF,$d,$a,$b,$c,$_[13],12,0x8b44f7af,/* 10 */ FF,$c,$d,$a,$b,$_[14],17,0xffff5bb1,/* 11 */ FF,$b,$c,$d,$a,$_[15],22,0x895cd7be,/* 12 */ FF,$a,$b,$c,$d,$_[16],7,0x6b901122,/* 13 */ FF,$d,$a,$b,$c,$_[17],12,0xfd987193,/* 14 */ FF,$c,$d,$a,$b,$_[18],17,0xa679438e,/* 15 */ FF,$b,$c,$d,$a,$_[19],22,0x49b40821,/* 16 */ GG,$a,$b,$c,$d,$_[5],5,0xf61e2562,/* 17 */ GG,$d,$a,$b,$c,$_[10],9,0xc040b340,/* 18 */ GG,$c,$d,$a,$b,$_[15],14,0x265e5a51,/* 19 */ GG,$b,$c,$d,$a,$_[4],20,0xe9b6c7aa,/* 20 */ GG,$a,$b,$c,$d,$_[9],5,0xd62f105d,/* 21 */ GG,$d,$a,$b,$c,$_[14],9,0x2441453,/* 22 */ GG,$c,$d,$a,$b,$_[19],14,0xd8a1e681,/* 23 */ GG,$b,$c,$d,$a,$_[8],20,0xe7d3fbc8,/* 24 */ GG,$a,$b,$c,$d,$_[13],5,0x21e1cde6,/* 25 */ GG,$d,$a,$b,$c,$_[18],9,0xc33707d6,/* 26 */ GG,$c,$d,$a,$b,$_[7],14,0xf4d50d87,/* 27 */ GG,$b,$c,$d,$a,$_[12],20,0x455a14ed,/* 28 */ GG,$a,$b,$c,$d,$_[17],5,0xa9e3e905,/* 29 */ GG,$d,$a,$b,$c,$_[6],9,0xfcefa3f8,/* 30 */ GG,$c,$d,$a,$b,$_[11],14,0x676f02d9,/* 31 */ GG,$b,$c,$d,$a,$_[16],20,0x8d2a4c8a,/* 32 */ HH,$a,$b,$c,$d,$_[9],4,0xfffa3942,/* 33 */ HH,$d,$a,$b,$c,$_[12],11,0x8771f681,/* 34 */ HH,$c,$d,$a,$b,$_[15],16,0x6d9d6122,/* 35 */ HH,$b,$c,$d,$a,$_[18],23,0xfde5380c,/* 36 */ HH,$a,$b,$c,$d,$_[5],4,0xa4beea44,/* 37 */ HH,$d,$a,$b,$c,$_[8],11,0x4bdecfa9,/* 38 */ HH,$c,$d,$a,$b,$_[11],16,0xf6bb4b60,/* 39 */ HH,$b,$c,$d,$a,$_[14],23,0xbebfbc70,/* 40 */ HH,$a,$b,$c,$d,$_[17],4,0x289b7ec6,/* 41 */ HH,$d,$a,$b,$c,$_[4],11,0xeaa127fa,/* 42 */ HH,$c,$d,$a,$b,$_[7],16,0xd4ef3085,/* 43 */ HH,$b,$c,$d,$a,$_[10],23,0x4881d05,/* 44 */ HH,$a,$b,$c,$d,$_[13],4,0xd9d4d039,/* 45 */ HH,$d,$a,$b,$c,$_[16],11,0xe6db99e5,/* 46 */ HH,$c,$d,$a,$b,$_[19],16,0x1fa27cf8,/* 47 */ HH,$b,$c,$d,$a,$_[6],23,0xc4ac5665,/* 48 */ II,$a,$b,$c,$d,$_[4],6,0xf4292244,/* 49 */ II,$d,$a,$b,$c,$_[11],10,0x432aff97,/* 50 */ II,$c,$d,$a,$b,$_[18],15,0xab9423a7,/* 51 */ II,$b,$c,$d,$a,$_[9],21,0xfc93a039,/* 52 */ II,$a,$b,$c,$d,$_[16],6,0x655b59c3,/* 53 */ II,$d,$a,$b,$c,$_[7],10,0x8f0ccc92,/* 54 */ II,$c,$d,$a,$b,$_[14],15,0xffeff47d,/* 55 */ II,$b,$c,$d,$a,$_[5],21,0x85845dd1,/* 56 */ II,$a,$b,$c,$d,$_[12],6,0x6fa87e4f,/* 57 */ II,$d,$a,$b,$c,$_[19],10,0xfe2ce6e0,/* 58 */ II,$c,$d,$a,$b,$_[10],15,0xa3014314,/* 59 */ II,$b,$c,$d,$a,$_[17],21,0x4e0811a1,/* 60 */ II,$a,$b,$c,$d,$_[8],6,0xf7537e82,/* 61 */ II,$d,$a,$b,$c,$_[15],10,0xbd3af235,/* 62 */ II,$c,$d,$a,$b,$_[6],15,0x2ad7d2bb,/* 63 */ II,$b,$c,$d,$a,$_[13],21,0xeb86d391,/* 64 */|; # padd a message to a multiple of 64 sub padding($) { my $l = length (my $msg = shift() . chr(128)); $msg .= "\0" x (($l%64<=56?56:120)-$l%64); $l = ($l-1)*8; $msg .= pack 'VV', $l & MAX , ($l >> 16 >> 16); } sub rotate_left($$) { #$_[0] << $_[1] | $_[0] >> (32 - $_[1]); #my $right = $_[0] >> (32 - $_[1]); #my $rmask = (1 << $_[1]) - 1; ($_[0] << $_[1]) | (( $_[0] >> (32 - $_[1]) ) & ((1 << $_[1]) - 1)); #$_[0] << $_[1] | (($_[0]>> (32 - $_[1])) & (1 << (32 - $_[1])) - 1); } sub gen_code { # Discard upper 32 bits on 64 bit archs. my $MSK = ((1 << 16) << 16) ? ' & ' . MAX : ''; # FF => "X0=rotate_left(((X1&X2)|(~X1&X3))+X0+X4+X6$MSK,X5)+X1$MSK;", # GG => "X0=rotate_left(((X1&X3)|(X2&(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;", my %f = ( FF => "X0=rotate_left((X3^(X1&(X2^X3)))+X0+X4+X6$MSK,X5)+X1$MSK;", GG => "X0=rotate_left((X2^(X3&(X1^X2)))+X0+X4+X6$MSK,X5)+X1$MSK;", HH => "X0=rotate_left((X1^X2^X3)+X0+X4+X6$MSK,X5)+X1$MSK;", II => "X0=rotate_left((X2^(X1|(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;", ); #unless ( (1 << 16) << 16) { %f = %{$CODES{'32bit'}} } #else { %f = %{$CODES{'64bit'}} } my %s = ( # shift lengths S11 => 7, S12 => 12, S13 => 17, S14 => 22, S21 => 5, S22 => 9, S23 => 14, S24 => 20, S31 => 4, S32 => 11, S33 => 16, S34 => 23, S41 => 6, S42 => 10, S43 => 15, S44 => 21 ); my $insert = ""; # while() { for (@GT::MD5::DATA) { # chomp; next unless /^[FGHI]/; my ($func,@x) = split /,/; my $c = $f{$func}; $c =~ s/X(\d)/$x[$1]/g; $c =~ s/(S\d{2})/$s{$1}/; $c =~ s/^(.*)=rotate_left\((.*),(.*)\)\+(.*)$//; #my $rotate = "(($2 << $3) || (($2 >> (32 - $3)) & (1 << $2) - 1)))"; $c = "\$r = $2; $1 = ((\$r << $3) | ((\$r >> (32 - $3)) & ((1 << $3) - 1))) + $4"; $insert .= "\t$c\n"; } my $dump = ' sub round { my ($a,$b,$c,$d) = @_[0 .. 3]; my $r; ' . $insert . ' $_[0]+$a' . $MSK . ', $_[1]+$b ' . $MSK . ', $_[2]+$c' . $MSK . ', $_[3]+$d' . $MSK . '; }'; eval $dump; #print "$dump\n"; #exit 0; } gen_code(); # object part of this module sub new { my $class = shift; bless {}, ref($class) || $class; } sub reset { my $self = shift; delete $self->{data}; $self } sub add(@) { my $self = shift; $self->{data} .= join'', @_; $self } sub addfile { my ($self,$fh) = @_; if (!ref($fh) && ref(\$fh) ne "GLOB") { require Symbol; $fh = Symbol::qualify($fh, scalar caller); } $self->{data} .= do{local$/;<$fh>}; $self } sub digest { md5(shift->{data}) } sub hexdigest { md5_hex(shift->{data}) } sub b64digest { md5_base64(shift->{data}) } sub md5 { my $message = padding(join'',@_); my ($a,$b,$c,$d) = (A,B,C,D); my $i; for $i (0 .. (length $message)/64-1) { my @X = unpack 'V16', substr $message,$i*64,64; ($a,$b,$c,$d) = round($a,$b,$c,$d,@X); } pack 'V4',$a,$b,$c,$d; } sub md5_hex { unpack 'H*', &md5; } sub md5_base64 { encode_base64(&md5); } sub encode_base64 ($) { my $res; while ($_[0] =~ /(.{1,45})/gs) { $res .= substr pack('u', $1), 1; chop $res; } $res =~ tr|` -_|AA-Za-z0-9+/|;#` chop $res;chop $res; $res; } END_OF_MODULE # Load either Digest::MD5 or GT::MD5 functions. eval { local $SIG{__DIE__}; require Digest::MD5; foreach (@EXPORT_OK) { delete $GT::MD5::{$_}; } # Do not remove. import Digest::MD5 (@EXPORT_OK); *GT::MD5::md5_hex = sub { &Digest::MD5::md5_hex }; *GT::MD5::md5 = sub { &Digest::MD5::md5 }; *GT::MD5::md5_base64 = sub { &Digest::MD5::md5_base64 }; @ISA = 'Digest::MD5'; 1; } or do { local $@; eval $DATA; $@ and die "GT::MD5 => can't compile: $@"; }; require Exporter; import Exporter; 1; __END__ =head1 NAME GT::MD5 - Perl implementation of Ron Rivests MD5 Algorithm. =head1 DISCLAIMER Majority of this module's code is borrowed from Digest::Perl::MD5 (Version 1.5). This is B an interface (like C) but a Perl implementation of MD5. It is written in perl only and because of this it is slow but it works without C-Code. You should use C instead of this module if it is available. This module is only usefull for =over 4 =item computers where you cannot install C (e.g. lack of a C-Compiler) =item encrypting only small amounts of data (less than one million bytes). I use it to hash passwords. =item educational purposes =back =head1 SYNOPSIS # Functional style use Digest::MD5 qw(md5 md5_hex md5_base64); $hash = md5 $data; $hash = md5_hex $data; $hash = md5_base64 $data; # OO style use Digest::MD5; $ctx = Digest::MD5->new; $ctx->add($data); $ctx->addfile(*FILE); $digest = $ctx->digest; $digest = $ctx->hexdigest; $digest = $ctx->b64digest; =head1 DESCRIPTION This modules has the same interface as the much faster C. So you can easily exchange them, e.g. BEGIN { eval { require Digest::MD5; import Digest::MD5 'md5_hex' }; if ($@) { # ups, no Digest::MD5 require Digest::Perl::MD5; import Digest::Perl::MD5 'md5_hex' } } If the C module is available it is used and if not you take C. You can also install the Perl part of Digest::MD5 together with Digest::Perl::MD5 and use Digest::MD5 as normal, it falls back to Digest::Perl::MD5 if it cannot load its object files. For a detailed Documentation see the C module. =head1 EXAMPLES The simplest way to use this library is to import the md5_hex() function (or one of its cousins): use Digest::Perl::MD5 'md5_hex'; print 'Digest is ', md5_hex('foobarbaz'), "\n"; The above example would print out the message Digest is 6df23dc03f9b54cc38a0fc1483df6e21 provided that the implementation is working correctly. The same checksum can also be calculated in OO style: use Digest::MD5; $md5 = Digest::MD5->new; $md5->add('foo', 'bar'); $md5->add('baz'); $digest = $md5->hexdigest; print "Digest is $digest\n"; =head1 LIMITATIONS This implementation of the MD5 algorithm has some limitations: =over 4 =item It's slow, very slow. I've done my very best but Digest::MD5 is still about 135 times faster. You can only encrypt Data up to one million bytes in an acceptable time. But it's very usefull for encrypting small amounts of data like passwords. =item You can only encrypt up to 2^32 bits = 512 MB on 32bit archs. You should use C for those amounts of data. =item C loads all data to encrypt into memory. This is a todo. =back =head1 SEE ALSO L L RFC 1321 =head1 COPYRIGHT This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 2000 Christian Lackas, Imperia Software Solutions Copyright 1998-1999 Gisle Aas. Copyright 1995-1996 Neil Winton. Copyright 1991-1992 RSA Data Security, Inc. The MD5 algorithm is defined in RFC 1321. The basic C code implementing the algorithm is derived from that in the RFC and is covered by the following copyright: =over 4 =item Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All rights reserved. License to copy and use this software is granted provided that it is identified as the "RSA Data Security, Inc. MD5 Message-Digest Algorithm" in all material mentioning or referencing this software or this function. License is also granted to make and use derivative works provided that such works are identified as "derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm" in all material mentioning or referencing the derived work. RSA Data Security, Inc. makes no representations concerning either the merchantability of this software or the suitability of this software for any particular purpose. It is provided "as is" without express or implied warranty of any kind. These notices must be retained in any copies of any part of this documentation and/or software. =back This copyright does not prohibit distribution of any version of Perl containing this extension under the terms of the GNU or Artistic licenses. =head1 AUTHORS The original MD5 interface was written by Neil Winton (C). C was made by Gisle Aas (I took his Interface and part of the documentation) Thanks to Guido Flohr for his 'use integer'-hint. This release was made by Christian Lackas . =cut private/lib/GT/MD5/0040755000076400010020000000000007477023142012507 5ustar alexcvsprivate/lib/GT/MD5/Crypt.pm0100644000076400010020000001332207453737211014147 0ustar alexcvs# GT::MD5::Crypt - adapted from CPAN Crypt::PasswdMD5 for use in the # Gossamer Thread module library. gt_md5_crypt was added which uses # "$GT$" as the magic string instead of the unix "$1$" or apache "$apr1$" # # Crypt::PasswdMD5: Module to provide an interoperable crypt() # function for modern Unix O/S. This is based on the code for # # /usr/src/libcrypt/crypt.c # # on a FreeBSD 2.2.5-RELEASE system, which included the following # notice. # # ---------------------------------------------------------------------------- # "THE BEER-WARE LICENSE" (Revision 42): # wrote this file. As long as you retain this notice you # can do whatever you want with this stuff. If we meet some day, and you think # this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp # ---------------------------------------------------------------------------- # # 19980710 lem@cantv.net: Initial release # 19990402 bryan@eai.com: Added apache_md5_crypt to create a valid hash # for use in .htpasswd files # 20001006 wrowe@lnd.com: Requested apache_md5_crypt to be # exported by default. # ################ package GT::MD5::Crypt; $VERSION='1.1'; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(unix_md5_crypt apache_md5_crypt gt_md5_crypt); $Magic = '$1$'; # Magic string $itoa64 = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; local $^W; use GT::MD5; sub to64 { my ($v, $n) = @_; my $ret = ''; while (--$n >= 0) { $ret .= substr($itoa64, $v & 0x3f, 1); $v >>= 6; } $ret; } sub apache_md5_crypt { # change the Magic string to match the one used by Apache local $Magic = '$apr1$'; unix_md5_crypt(@_); } sub gt_md5_crypt { # change the Magic string to put our signature in the password local $Magic = '$GT$'; unix_md5_crypt(@_); } sub unix_md5_crypt { my($pw, $salt) = @_; my $passwd; $salt =~ s/^\Q$Magic//; # Take care of the magic string if # if present. $salt =~ s/^(.*)\$.*$/$1/; # Salt can have up to 8 chars... $salt = substr($salt, 0, 8); $ctx = new GT::MD5; # Here we start the calculation $ctx->add($pw); # Original password... $ctx->add($Magic); # ...our magic string... $ctx->add($salt); # ...the salt... my ($final) = new GT::MD5; $final->add($pw); $final->add($salt); $final->add($pw); $final = $final->digest; for ($pl = length($pw); $pl > 0; $pl -= 16) { $ctx->add(substr($final, 0, $pl > 16 ? 16 : $pl)); } # Now the 'weird' xform for ($i = length($pw); $i; $i >>= 1) { if ($i & 1) { $ctx->add(pack("C", 0)); } # This comes from the original version, # where a memset() is done to $final # before this loop. else { $ctx->add(substr($pw, 0, 1)); } } $final = $ctx->digest; # The following is supposed to make # things run slower. In perl, perhaps # it'll be *really* slow! for ($i = 0; $i < 1000; $i++) { $ctx1 = new GT::MD5; if ($i & 1) { $ctx1->add($pw); } else { $ctx1->add(substr($final, 0, 16)); } if ($i % 3) { $ctx1->add($salt); } if ($i % 7) { $ctx1->add($pw); } if ($i & 1) { $ctx1->add(substr($final, 0, 16)); } else { $ctx1->add($pw); } $final = $ctx1->digest; } # Final xform $passwd = ''; $passwd .= to64(int(unpack("C", (substr($final, 0, 1))) << 16) | int(unpack("C", (substr($final, 6, 1))) << 8) | int(unpack("C", (substr($final, 12, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 1, 1))) << 16) | int(unpack("C", (substr($final, 7, 1))) << 8) | int(unpack("C", (substr($final, 13, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 2, 1))) << 16) | int(unpack("C", (substr($final, 8, 1))) << 8) | int(unpack("C", (substr($final, 14, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 3, 1))) << 16) | int(unpack("C", (substr($final, 9, 1))) << 8) | int(unpack("C", (substr($final, 15, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 4, 1))) << 16) | int(unpack("C", (substr($final, 10, 1))) << 8) | int(unpack("C", (substr($final, 5, 1)))), 4); $passwd .= to64(int(unpack("C", substr($final, 11, 1))), 2); $final = ''; $Magic . $salt . '$' . $passwd; } 1; __END__ =head1 NAME unix_md5_crypt - Provides interoperable MD5-based crypt() function =head1 SYNOPSIS use GT::MD5::Crypt; $cryptedpassword = unix_md5_crypt($password, $salt); =head1 DESCRIPTION the C provides a crypt()-compatible interface to the rather new MD5-based crypt() function found in modern operating systems. It's based on the implementation found on FreeBSD 2.2.[56]-RELEASE and contains the following license in it: "THE BEER-WARE LICENSE" (Revision 42): wrote this file. As long as you retain this notice you can do whatever you want with this stuff. If we meet some day, and you think this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp C provides a function compatible with Apache's C<.htpasswd> files. This was contributed by Bryan Hart . As suggested by William A. Rowe, Jr. , it is exported by default. =cut private/lib/GT/CGI/0040755000076400010020000000000007477023142012524 5ustar alexcvsprivate/lib/GT/CGI/Cookie.pm0100644000076400010020000000526107472566507014310 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::CGI::Cookie # $Id: Cookie.pm,v 1.1 2002/05/22 00:58:47 jagerman Exp $ # # Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: # Handles cookie creation and formatting. # package GT::CGI::Cookie; #================================================================================ use strict; use GT::CGI; use GT::Base; use vars qw/@ISA $ATTRIBS @MON @WDAY/; @ISA = qw/GT::Base/; $ATTRIBS = { -name => '', -value => '', -expires => '', -path => '', -domain => '', -secure => '' }; @MON = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; @WDAY = qw/Sun Mon Tue Wed Thu Fri Sat/; sub cookie_header { #-------------------------------------------------------------------------------- # Returns a cookie header. # my $self = shift; # make sure we have a name to use.., $self->{'-name'} or return; my $name = GT::CGI::escape($self->{'-name'}); my $value = GT::CGI::escape($self->{'-value'}); # build the header that creats the cookie my $header = "Set-Cookie: $name=$value"; $self->{'-expires'} and $header .= "; expires=" . _format_date ('-', $self->{'-expires'}); $self->{'-path'} and $header .= "; path=$self->{-path}"; $self->{'-domain'} and $header .= "; domain=$self->{-domain}"; $self->{'-secure'} and $header .= "; secure"; return "$header"; } sub _format_date { # ------------------------------------------------------------------- # Return a string in http_gmt format, but accepts one in unknown format. # Wed, 23 Aug 2000 21:20:14 GMT # my ($sep, $datestr) = @_; my $unix_time = defined $datestr ? _expire_calc($datestr) : time(); my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime ($unix_time); $year = $year + 1900; my $date = sprintf("%s, %02d$sep%s$sep%04d %02d:%02d:%02d GMT", $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); return $date; } sub _expire_calc { # ------------------------------------------------------------------- # Calculates when a date based on +- times. See CGI.pm for more info. # my $time = shift; my %mult = qw/s 1 m 60 h 3600 d 86400 M 2592000 y 31536000/; my $offset; if (! $time or (lc $time eq 'now')) { $offset = 0; } elsif ($time =~ /^\d+/) { return $time; } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy]?)/) { $offset = ($mult{$2} || 1)*$1; } else { return $time; } return time() + $offset; } 1; private/lib/GT/CGI/EventLoop.pm0100644000076400010020000003673507455647123015017 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::CGI::EventLoop # Author : Scott Beck # $Id: EventLoop.pm,v 1.3 2002/04/12 21:14:59 sbeck Exp $ # # Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: Impliments an EventLoop API for CGI programming # package GT::CGI::EventLoop; # ================================================================== use vars qw/$ATTRIBS $ERRORS @EXPORT_OK %EXPORT_TAGS/; use strict; use bases 'GT::Base' => ''; use constants STOP => 1, EXIT => 2, CONT => 3, HEAP => 0, EVENT => 1, IN => 2, CGI => 3, ARG0 => 4, ARG1 => 5, ARG2 => 6, ARG3 => 7, ARG4 => 8, ARG5 => 9, ARG6 => 10, ARG7 => 11, ARG8 => 12, ARG9 => 13; use GT::CGI; use GT::MIMETypes; use Exporter; sub import; *import = *Exporter::import; $ERRORS = { NOACTION => 'No action was passed from CGI input and no default action was set', NOFUNC => 'No function in %s' }; $ATTRIBS = { do => 'do', format_page_tags => undef, default_do => undef, init_events => undef, init_events_name => undef, default_page => 'home', default_group => undef, default_page_pre_event => undef, default_page_post_event => undef, default_group_pre_event => undef, default_group_post_event => undef, needs_array_input => undef, plugin_object => undef, template_path => undef, pre_package => '', cgi => undef, in => {}, heap => {}, page_events => {}, page_pre_events => {}, page_post_events => {}, group_pre_events => {}, group_post_events => {}, groups => {}, group => undef, page => undef, print_page => \>::CGI::EventLoop::print_page, status => CONT, cookies => [] }; @EXPORT_OK = qw/ STOP EXIT CONT HEAP EVENT IN CGI ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9 /; %EXPORT_TAGS = ( all => [@EXPORT_OK], status => [qw/STOP EXIT CONT/], args => [qw/ HEAP EVENT IN CGI ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9 /] ); sub init { # -------------------------------------------------------------------- my $self = shift; $self->set( @_ ) if @_; $self->{cgi} ||= new GT::CGI; for ( $self->{cgi}->param ) { my @val = $self->{cgi}->param($_); my $val; my $match; for my $field ( @{$self->{needs_array_input}} ) { if ( $_ eq $field ) { $match = 1; last; } } if ( !$match ) { $val = $val[0]; } else { $val = \@val; } $self->{in}{$_} = $val; } } sub mainloop { # -------------------------------------------------------------------- my $self = shift; $self->init( @_ ) if @_; if ( !defined $self->{in}{$self->{do}} ) { if ( defined $self->{default_do} ) { $self->{in}{$self->{do}} = $self->{default_do}; } else { $self->fatal( 'NOACTION' ); } } if ( $self->{init_events} ) { local $self->{in}{$self->{do}} = $self->{init_events_name} if $self->{init_events_name}; $self->dispatch( $self->{init_events} ); return if $self->{status} == EXIT; } $self->_call_group; $self->_call_page; } sub do_param { # -------------------------------------------------------------------- my $self = shift; if ( @_ ) { $self->add_hidden( $self->{do} => $_[0] ); } return $self->{in}{$self->{do}}; } sub stop { $_[0]->{status} = STOP } sub exit { $_[0]->{status} = EXIT } sub cont { $_[0]->{status} = CONT } sub _call_group { # -------------------------------------------------------------------- my ( $self ) = @_; $self->{group} ||= $self->{in}{$self->{do}} || $self->{default_do}; my $orig_group = $self->{group}; # FIXME Add infinite recursion checks! for ( keys %{$self->{groups}} ) { if ( index( $self->{group}, $_ ) == 0 ) { if ( exists $self->{group_pre_events}{$_} ) { $self->dispatch( $self->{group_pre_events}{$_} ); return if $self->{status} == EXIT; if ( $self->{group} ne $orig_group ) { return $self->_call_group; } } elsif ( defined $self->{default_group_pre_event} ) { $self->dispatch( $self->{default_group_pre_event} ); return if $self->{status} == EXIT; if ( $self->{group} ne $orig_group ) { return $self->_call_group; } } $self->dispatch( $self->{groups}{$_} ); if ( $self->{group} ne $orig_group ) { return $self->_call_group; } if ( exists $self->{group_post_events}{$_} ) { $self->dispatch( $self->{group_post_events}{$_} ); return if $self->{status} == EXIT; if ( $self->{group} ne $orig_group ) { return $self->_call_group; } } elsif ( defined $self->{default_group_post_event} ) { $self->dispatch( $self->{default_group_post_event} ); return if $self->{status} == EXIT; if ( $self->{group} ne $orig_group ) { return $self->_call_group; } } return; } } # Default group $self->dispatch( $self->{default_group} ) if $self->{default_group}; if ( $self->{default_group} and $self->{group} ne $orig_group ) { return $self->_call_group; } } sub _call_page { # -------------------------------------------------------------------- my ( $self ) = @_; if ( !$self->{page} ) { $self->page( $self->{default_page} ); } my $orig_page = $self->{page}; if ( exists $self->{page_pre_events}{$self->{page}} ) { $self->dispatch( $self->{page_pre_events}{$self->{page}} ); return if $self->{status} == EXIT; if ( $self->{page} ne $orig_page ) { return $self->_call_page; } } elsif ( defined $self->{default_page_pre_event} ) { $self->dispatch( $self->{default_page_pre_event} ); return if $self->{status} == EXIT; if ( $self->{page} ne $orig_page ) { return $self->_call_page; } } $self->{print_page}->( $self ); # Run post page events, can't change the page on a post event if ( exists $self->{page_post_events}{$self->{page}} ) { $self->dispatch( $self->{page_post_events}{$self->{page}} ); } elsif ( defined $self->{default_page_post_event} ) { $self->dispatch( $self->{default_page_post_event} ); } } sub cookie_jar { # -------------------------------------------------------------------- # $obj->cookie_jar($cookie_object); # --------------------------------- # Stores cookies for printing when print_page is called. # $cookie_object should be a GT::CGI::Cookie object. Passing undef # will empty the cookies array ref. # my $self = shift; if ( !defined( $_[0] ) and @_ > 0 ) { $self->{cookies} = []; } elsif ( @_ > 0 ) { push( @{$self->{cookies}}, $_[0] ); } return $self->{cookies}; } sub add_hidden { # -------------------------------------------------------------------- my $self = shift; if ( @_ and !defined( $_[0] ) ) { $self->{hidden} = {}; } elsif ( @_ ) { $self->{hidden}{$_[0]} = $_[1]; } } sub remove_hidden { # -------------------------------------------------------------------- my $self = shift; return delete $self->{hidden}{$_[0]}; } sub get_url_hidden { # -------------------------------------------------------------------- my ( $self ) = @_; my $ret = ''; for ( keys %{$self->{hidden}} ) { next unless defined $self->{hidden}{$_}; $ret .= $self->{cgi}->escape( $_ ).'='.$self->{cgi}->escape( $self->{hidden}{$_} ).';'; } return $ret; } sub get_form_hidden { # -------------------------------------------------------------------- my ( $self ) = @_; my $ret = ''; for ( keys %{$self->{hidden}} ) { next unless defined $self->{hidden}{$_}; $ret .= ''; } return $ret; } sub page { # -------------------------------------------------------------------- my $self = shift; if ( @_ > 0 ) { $self->{page} = $self->guess_page( $_[0] ); $self->debug( "Set page to $self->{page}" ) if $self->{_debug}; $self->yield( $self->{page_events} ) if $self->{page_events}; } return $self->{page}; } sub guess_page { # -------------------------------------------------------------------- my ( $self, $page ) = @_; if ( -e "$self->{template_path}/$page.htm" ) { $page = "$page.htm"; } elsif ( -e "$self->{template_path}/$page.html" ) { $page = "$page.html"; } return $page; } sub tags { # -------------------------------------------------------------------- my $self = shift; my ( %tags ) = ref( $_[0] ) eq 'HASH' ? %{$_[0]} : @_; for ( keys %tags ) { $self->{tags}{$_} = $tags{$_}; } return $self->{tags}; } sub default_tags { # -------------------------------------------------------------------- my ( $self, %tags ) = @_; my $set; for ( keys %tags ) { $set->{$_} = ( defined( $self->{in}{$_} ) and length( $self->{in}{$_} ) ? $self->{in}{$_} : $tags{$_} ); } $self->tags( %$set ); } sub print_page { # -------------------------------------------------------------------- my ( $self ) = @_; my $form_hidden = $self->get_form_hidden; my $url_hidden = $self->get_url_hidden; my $tags = $self->tags( url_hidden => \$url_hidden, form_hidden => \$form_hidden ); $tags = $self->yield( $self->{format_page_tags}, $tags ) if defined $self->{format_page_tags}; my $page = $self->page || 'index.htm'; # Cookies can be set with CGI input my $cookies = []; if ( $self->{in}{'set-cookie'} ) { foreach my $key ( keys %{$self->{in}} ) { if ( $key =~ /^cookie-(.*)/ ) { push @$cookies, $self->{cgi}->cookie( -name => $1, -value => $self->{in}{$key}, -path => '/' ); } } } # See if we have any cookies in out cookie jar (used through program operation to set cookies without printing # a header) if ( @{$self->cookie_jar} ) { push @$cookies, @{$self->cookie_jar}; } # If we have cookie header to print print them print @{$cookies} ? $self->{cgi}->header( -cookie => $cookies, -type => GT::MIMETypes->guess_type( $page ) ) : $self->{cgi}->header( GT::MIMETypes->guess_type( $page ) ); my $base = $self->{template_path}; # Make sure the template exists and is readable -e "$base/$page" or die "No page ($base/$page)"; -r _ or die "Page isn't readable by this process ($< $>) ($base/$page)"; require GT::Template; GT::Template->parse( $page, $tags, { root => $base, escape => 1, print => 1, heap => [ $self->func_args ] } ); } sub page_pre_events { # -------------------------------------------------------------------- my ( $self, %in ) = @_; if ( keys %in ) { $self->{page_pre_events} = {}; for ( keys %in ) { my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ]; $self->{page_pre_events}{$self->guess_page( $_ )} = $val; } } return $self->{page_pre_events}; } sub page_post_events { # -------------------------------------------------------------------- my ( $self, %in ) = @_; if ( keys %in ) { $self->{page_post_events} = {}; for ( keys %in ) { my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ]; $self->{page_post_events}{$self->guess_page( $_ )} = $val; } } return $self->{page_post_events}; } sub group_pre_events { # -------------------------------------------------------------------- my ( $self, %in ) = @_; if ( keys %in ) { $self->{group_pre_events} = {}; for ( keys %in ) { my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ]; $self->{group_pre_events}{$_} = $val; } } return $self->{group_pre_events}; } sub group_post_events { # -------------------------------------------------------------------- my ( $self, %in ) = @_; if ( keys %in ) { $self->{group_post_events} = {}; for ( keys %in ) { my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ]; $self->{group_post_events}{$_} = $val; } } return $self->{group_post_events}; } sub dispatch { # -------------------------------------------------------------------- my ( $self, $pfunc, @args ) = @_; $pfunc = ref( $pfunc ) eq 'ARRAY' ? $pfunc : [ $pfunc ]; for ( @$pfunc ) { $self->yield( $_, @args ); return if $self->{status} == EXIT or $self->{status} == STOP; } } sub yield { # -------------------------------------------------------------------- my ( $self, $pfunc, @args ) = @_; if ( !ref( $pfunc ) ) { $self->debug( "Yielding $pfunc" ) if $self->{_debug} > 1; my ( $pkg, $func ); if ( index( $pfunc, '::' ) != -1 ) { ($pkg, $func) = $pfunc =~ /^(.*)::(.*)$/; } else { $func = $pfunc; } defined( $func ) or $self->fatal( 'NOFUNC', $pfunc ); $pkg = $self->{pre_package}.$pkg if $self->{pre_package} and $pkg; $pkg ||= $self->{pre_package} if $self->{pre_package}; $pkg ||= 'main'; $pkg =~ s/::$//; no strict 'refs'; unless ( defined %{$pkg . '::'} ) { eval "require $pkg"; die "Could not compile $pkg; Reason: $@" if $@; } if ( defined $self->{plugin_object} ) { $self->debug( "dispatching --> $pkg\::$func" ) if $self->{_debug}; return $self->{plugin_object}->dispatch( $pkg.'::'.$func, \&{$pkg.'::'.$func}, $self->func_args(@args) ); } else { no strict 'refs'; $self->debug( "Calling $pkg\::$func" ) if $self->{_debug}; return &{$pkg.'::'.$func}( $self->func_args(@args) ); } $self->yield( $_, @args ); } elsif ( ref( $pfunc ) eq 'CODE' ) { $self->debug( "In yeild with code ref.") if $self->{_debug}; if ( defined $self->{plugin_object} ) { $self->debug( "dispatching --> $self->{in}{$self->{do}}" ) if $self->{_debug}; return $self->{plugin_object}->dispatch( $self->{in}{$self->{do}}, $pfunc, $self->func_args(@args) ); } else { $self->debug( "Calling code ref" ) if $self->{_debug}; return $pfunc->( $self->func_args(@args) ); } } } sub func_args { $_[0]->{heap}, $_[0], $_[0]->{in}, $_[0]->{cgi}, @_[1 .. $#_] } 1; private/lib/GT/CGI/Fh.pm0100644000076400010020000000352007472566507013430 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::CGI::Fh # $Id: Fh.pm,v 1.1 2002/05/22 00:58:47 jagerman Exp $ # # Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: # Magic filehandle that prints the name, but is still a filehandle for reads - # just like CGI.pm. # package GT::CGI::Fh; # =================================================================== use strict 'vars', 'subs'; use vars qw/$FH/; use Fcntl qw/O_RDWR O_EXCL/; use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback' => 1; sub new { # ------------------------------------------------------------------- # Create a new filehandle based on a counter, and the filename. # my ($pkg, $name, $file, $delete) = @_; my $fname = sprintf("FH%05d%s", ++$FH, $name); $fname =~ s/([:'%])/sprintf '%%%02X', ord $1/eg; my $fh = \do { local *{$fname}; *{$fname} }; sysopen($fh, $file, O_RDWR | O_EXCL, 0600) or die "Can't open file: $file ($!)"; unlink($file) if $delete; bless $fh, $pkg; return $fh; } sub as_string { # ------------------------------------------------------------------- # Return the filename, strip off leading junk first. # my $self = shift; my $fn = $$self; $fn =~ s/%(..)/ chr(hex($1)) /eg; $fn =~ s/^\*GT::CGI::Fh::FH\d{5}//; return $fn; } sub compare { # ------------------------------------------------------------------- # Do comparisions, uses as_string to get file name first. # my $self = shift; my $value = shift; return "$self" cmp $value; } DESTROY { # ------------------------------------------------------------------- # Close file handle. # my $self = shift; close $self; } 1; private/lib/GT/CGI/MultiPart.pm0100644000076400010020000001641207472566507015020 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::CGI::MultiPart # $Id: MultiPart.pm,v 1.1 2002/05/22 00:58:47 jagerman Exp $ # # Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: # Multipart form handling for GT::CGI objects. # # This is taken almost entirely from CGI.pm, and is loaded on demand. # package GT::CGI::MultiPart; # ============================================================================== use strict 'vars', 'subs'; use GT::CGI; use GT::Base; use GT::TempFile(); use vars qw/$DEBUG $ERRORS @ISA $ATTRIBS $CRLF/; @ISA = qw/GT::Base/; use constants BLOCK_SIZE => 4096, MAX_READS => 2000; $CRLF = GT::CGI::CRLF; $ATTRIBS = { fh => undef, # web request on stdin buffer => '', # buffer to hold tmp data length => 0, # length of file to parse boundary => undef, # mime boundary to look for fillunit => BLOCK_SIZE, # amount to read per chunk safety => 0 # safety counter }; $ERRORS = { NOBOUNDARY => "Unable to find a MIME boundary in environment. Content-type looks like: %s", CLIENTABORT => "Unable to read data from server. Still have %s bytes to read, but got 0. Data in buffer is: %s", BADMULTIPART => "Invalid multipart message. Nothing left to read, and can't find closing boundary. Data in buffer is: %s" }; sub parse { # ------------------------------------------------------------------- # Parses a multipart form to handle file uploads. # my ($class, $cgi) = @_; # We override any fatal handlers as our handlers typically create a CGI object # avoiding a nasty loop. local $SIG{__DIE__} = 'DEFAULT'; # We only load the multipart parser if we have multipart code. my $parser = $class->new or return; my ($header, $name, $value, $filename); until ($parser->eof) { $header = $parser->read_header or return die "BADREQUEST"; $header->{'Content-Disposition'} =~ m/ name=(?:"([^"]*)"|((?!")[^;]*))/; $name = $1 || $2; ($filename) = $header->{'Content-Disposition'} =~ m/ filename="?([^\";]*)"?/; # Not a file, just regular form data. if (! defined $filename or $filename eq '') { $value = $parser->read_body; # Netscape 6 does some fun things with line feeds in multipart form data $value =~ s/\r\r/\r/g; # What it does on unix $value =~ s/\r\n/\n/g if $^O eq 'MSWin32'; push @{$cgi->{params}->{$name}}, $value; next; } # Print out the data to a temp file. local $\; my $tmp_file = new GT::TempFile; require GT::CGI::Fh; my $fh = GT::CGI::Fh->new($filename, $$tmp_file, 0); binmode $fh; my $data; while (defined($data = $parser->read)) { print $fh $data; } seek $fh, 0, 0; push @{$cgi->{params}->{$name}}, $fh; } } sub init { # ------------------------------------------------------------------- # Initilize our object. # $DEBUG = $GT::CGI::DEBUG; my $self = shift; # Get the boundary marker. my $boundary; if (defined $ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /boundary=\"?([^\";,]+)\"?/) { $boundary = $1; } else { return $self->error("NOBOUNDARY", "FATAL", $ENV{CONTENT_TYPE}); } $self->{boundary} = "--$boundary"; # Get our filehandle. binmode(STDIN); # And if the boundary is > the BLOCK_SIZE, adjust. if (length $boundary > $self->{fillunit}) { $self->{fillunit} = length $boundary; } # Set the content-length. $self->{length} = $ENV{CONTENT_LENGTH} || 0; # Read the preamble and the topmost (boundary) line plus the CRLF. while ($self->read) { } } sub fill_buffer { # ------------------------------------------------------------------- # Fill buffer. # my ($self, $bytes) = @_; return unless $self->{length}; my $boundary_length = length $self->{boundary}; my $buffer_length = length $self->{buffer}; my $bytes_to_read = $bytes - $buffer_length + $boundary_length + 2; $bytes_to_read = $self->{length} if $self->{length} < $bytes_to_read; my $bytes_read = read(STDIN, $self->{buffer}, $bytes_to_read, $buffer_length); if (! defined $self->{buffer}) { $self->{buffer} = ''; } if ($bytes_read == 0) { if ($self->{safety}++ > MAX_READS) { return $self->error(CLIENTABORT => FATAL => $self->{length}, $self->{buffer}); } } else { $self->{safety} = 0; } $self->{length} -= $bytes_read; } sub read { # ------------------------------------------------------------------- # Read some input. # my $self = shift; my $bytes = $self->{fillunit}; # Load up self->{buffer} with data. $self->fill_buffer($bytes); # find the boundary (if exists). my $start = index($self->{buffer}, $self->{boundary}); # Make sure the post was formed properly. unless (($start >= 0) or ($self->{length} > 0)) { return $self->error(BADMULTIPART => FATAL => $self->{buffer}); } if ($start == 0) { # Quit if we found the last boundary at the beginning. if (index($self->{buffer},"$self->{boundary}--") == 0) { $self->{buffer} = ''; $self->{length} = 0; return; } # Otherwise remove the boundary (+2 to remove line feeds). substr($self->{buffer}, 0, length ($self->{boundary}) + 2) = ''; return; } my $bytes_to_return; if ($start > 0) { $bytes_to_return = $start > $bytes ? $bytes : $start; } else { $bytes_to_return = $bytes - length($self->{boundary}) + 1; } my $return = substr($self->{buffer}, 0, $bytes_to_return); substr($self->{buffer}, 0, $bytes_to_return) = ''; return $start > 0 ? substr($return, 0, -2) : $return; } sub read_header { # ------------------------------------------------------------------- # Reads the header. # my $self = shift; my ($ok, $bad, $end, $safety) = (0, 0); until ($ok or $bad) { $self->fill_buffer($self->{fillunit}); $ok++ if ($end = index($self->{buffer}, "$CRLF$CRLF")) >= 0; $ok++ if $self->{buffer} eq ''; $bad++ if !$ok and $self->{length} <= 0; return if $safety++ >= 10; } return if $bad; my $header = substr($self->{buffer}, 0, $end + 2); substr($self->{buffer}, 0, $end + 4) = ''; my %header; my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; $header =~ s/$CRLF\s+/ /og; while ($header =~ /($token+):\s+([^$CRLF]*)/go) { my ($field_name,$field_value) = ($1,$2); $field_name =~ s/\b(\w)/\u$1/g; $header{$field_name} = $field_value; } return \%header; } sub read_body { # ------------------------------------------------------------------- # Reads a body and returns as a single scalar value. # my $self = shift; my $data = ''; my $return = ''; while (defined($data = $self->read)) { $return .= $data; } return $return; } sub eof { # ------------------------------------------------------------------- # Return true when we've finished reading. # my $self = shift; return 1 if length $self->{buffer} == 0 and $self->{length} <= 0; } 1; private/lib/GT/CGI.pm0100644000076400010020000005550607472566507013106 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::CGI # Author : Aki Mimoto # $Id: CGI.pm,v 1.102 2002/05/22 00:58:47 jagerman Exp $ # # Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: # Implements CGI.pm's CGI functionality, but faster. # package GT::CGI; # =============================================================== use strict; use GT::Base(':all'); # Imports $MOD_PERL, $SPEEDY and $PERSIST use vars qw/@ISA $DEBUG $VERSION $ATTRIBS $ERRORS $PRINTED_HEAD $FORM_PARSED %PARAMS %COOKIES @EXPORT_OK %EXPORT_TAGS/; use GT::AutoLoader; require Exporter; @ISA = qw/GT::Base/; $DEBUG = 0; $VERSION = sprintf "%d.%03d", q$Revision: 1.102 $ =~ /(\d+)\.(\d+)/; $ATTRIBS = { nph => 0, p => '' }; $ERRORS = { INVALIDCOOKIE => "Invalid cookie passed to header: %s", INVALIDDATE => "Date '%s' is not a valid date format.", }; use constants CRLF => "\015\012"; $PRINTED_HEAD = 0; $FORM_PARSED = 0; %PARAMS = (); %COOKIES = (); @EXPORT_OK = qw/escape unescape html_escape html_unescape/; %EXPORT_TAGS = ( escape => [qw/escape unescape html_escape html_unescape/] ); # Pre load our compiled if under mod_perl/speedy. if ($PERSIST) { require GT::CGI::Cookie; require GT::CGI::MultiPart; require GT::CGI::Fh; } sub load_data { #-------------------------------------------------------------------------------- # Loads the form information into PARAMS. Data comes from either # a multipart form, a GET Request, a POST request, or as arguments from command # line. # my $self = shift; %PARAMS = (); %COOKIES = (); # Load form data. my $method = defined $ENV{REQUEST_METHOD} ? uc $ENV{REQUEST_METHOD} : ''; my $content_length = defined $ENV{'CONTENT_LENGTH'} ? $ENV{'CONTENT_LENGTH'} : 0; if ($method eq 'GET') { $self->parse_str(defined $ENV{QUERY_STRING} ? $ENV{QUERY_STRING} : ''); } elsif ($method eq 'POST') { if ($content_length) { if ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /^multipart/) { require GT::CGI::MultiPart; GT::CGI::MultiPart->parse($self); } else { read(STDIN, my $data, $content_length, 0); $data =~ s/\r?\n/&/g; $self->parse_str($data); } } } else { my $data = join "&", @ARGV; $self->parse_str($data); } # Load cookies. if (defined $ENV{HTTP_COOKIE}) { for (split /;\s*/, $ENV{HTTP_COOKIE}) { /(.*)=(.*)/; my ($key, $val) = (unescape($1), unescape($2)); $val = [split '&', $val]; $self->{cookies}->{$key} = $val; } } else { %{$self->{cookies}} = (); } # If we are under mod_perl we let mod_perl know that it should call reset_param # when a request is finished. $MOD_PERL and require Apache and $Apache::ServerStarting != 1 and Apache->request->register_cleanup(\&reset_env); $SPEEDY and require CGI::SpeedyCGI and CGI::SpeedyCGI->new->register_cleanup (\&reset_env ); # Parse form buttons, allowing you to pass in name="foo=bar;a=b;c=d" as a name # tag in the form. for (keys %{$self->{params}}) { if (index($_, '=') >= 0) { next if substr($_, -2) eq '.y'; (my $key = $_) =~ s/\.x$//; $self->parse_str($key); } } # Save the data for caching while (my ($k, $v) = each %{$self->{params}}) { push @{$PARAMS{$k}}, @$v; } while (my ($k, $v) = each %{$self->{cookies}}) { push @{$COOKIES{$_}}, @$v; } $FORM_PARSED = 1; } sub class_new { # -------------------------------------------------------------------------------- # Creates an object to be used for all class methods, this affects the global # cookies and params. # my $self = bless {} => shift; $self->load_data unless ($FORM_PARSED); $self->{cookies} = \%COOKIES; $self->{params} = \%PARAMS; for (keys %{$ATTRIBS}) { $self->{$_} = $ATTRIBS->{$_} } return $self; } sub reset_env { # -------------------------------------------------------------------------------- # Reset the global environment. # %PARAMS = (); %COOKIES = (); $PRINTED_HEAD = 0; $FORM_PARSED = 0; 1; } sub init { #-------------------------------------------------------------------------------- # Called from GT::Base when a new object is created. # my $self = shift; # If we are passed a single argument, then we load our data from # the input. if (@_ == 1) { my $p = $_[0]; if (ref $p eq 'GT::CGI') { $p = $p->query_string; } $self->parse_str($p ? "&$p" : ""); if (defined $ENV{HTTP_COOKIE}) { for (split /;\s*/, $ENV{HTTP_COOKIE}) { /(.*)=(.*)/; my ($key, $val) = (unescape($1), unescape($2)); $val = [split '&', $val]; $self->{cookies}->{$key} = $val; } } $FORM_PARSED = 1; } else { $self->set(@_) if @_; # If we have the form parsed, then we need to copy the data into self. if ($FORM_PARSED) { while (my ($k, $v) = each %PARAMS) { push @{$self->{params}->{$k}}, @$v; } while (my ($k, $v) = each %COOKIES) { push @{$self->{cookies}->{$k}}, @$v; } } } return $self; } $COMPILE{get_hash} = __LINE__ . <<'END_OF_SUB'; sub get_hash { #------------------------------------------------------------------------------- # Returns the parameters as a HASH, with multiple values becoming an array # reference. # my $self = shift; $self = $self->class_new unless ref $self; $FORM_PARSED or $self->load_data(); my $join = defined $_[0] ? $_[0] : 0; keys %{$self->{params}} or return {}; # Construct hash ref and return it my $opts = {}; foreach (keys %{$self->{params}}) { my @vals = @{$self->{params}->{$_}}; $opts->{$_} = @vals > 1 ? \@vals : $vals[0]; } return $opts; } END_OF_SUB $COMPILE{delete} = __LINE__ . <<'END_OF_SUB'; sub delete { #-------------------------------------------------------------------------------- # Remove an element from the parameters. # my ($self, $param) = @_; $self = $self->class_new unless ref $self; $FORM_PARSED or $self->load_data(); exists $self->{params}->{$param} and return wantarray ? @{delete $self->{params}->{$param}} : (@{delete $self->{params}->{$param}})[0]; return; } END_OF_SUB $COMPILE{cookie} = __LINE__ . <<'END_OF_SUB'; sub cookie { #-------------------------------------------------------------------------------- # Creates a new cookie for the user, implemented just like CGI.pm. # my $self = shift; # Not used, don't care if it's self/class.; $self = $self->class_new unless ref $self; $FORM_PARSED or $self->load_data(); my %data = ( @_ ) if ( @_ and @_ % 2 == 0 ); if (@_ == 0) { # Return keys. return keys %{$self->{cookies}}; } elsif (@_ == 1) { # Return value of param passed in. my $param = shift; return unless (defined ($param) and $self->{cookies}->{$param}); return wantarray ? @{$self->{cookies}->{$param}} : $self->{cookies}->{$param}->[0]; } elsif (@_ == 2) { require GT::CGI::Cookie; return GT::CGI::Cookie->new(-name => $_[0], -value => $_[1]); } elsif (defined $data{'-value'}) { require GT::CGI::Cookie; return GT::CGI::Cookie->new(%data); } else { # Set parameter. my ($param, $value) = @_; $self->{cookies}->{$param} = (ref $value eq 'ARRAY' ? $value : [$value]); } } END_OF_SUB $COMPILE{set} = __LINE__ . <<'END_OF_SUB'; sub set { #-------------------------------------------------------------------------------- # Let's you set a key/val parameter. # my $self = shift; $self = $self->class_new unless ref $self; $FORM_PARSED or $self->load_data(); my $params = $self->common_param(@_); foreach my $key (keys %$params) { $self->{params}->{$key} = $params->{$key}; } return {%{$self->{params}}}; } END_OF_SUB sub param { #-------------------------------------------------------------------------------- # Mimick CGI's param function for get/set. # my $self = shift; # Not used, don't care if it's self/class.; $self = $self->class_new unless ref $self; $FORM_PARSED or $self->load_data(); if (@_ == 0) { # Return keys. return keys %{$self->{params}}; } elsif (@_ == 1) { # Return value of param passed in. my $param = shift; return unless (defined ($param) and $self->{params}->{$param}); return wantarray ? @{$self->{params}->{$param}} : $self->{params}->{$param}->[0]; } else { # Set parameter. my ($param, $value) = @_; $self->{params}->{$param} = [ref $value eq 'ARRAY' ? @$value : $value]; } } sub header { #-------------------------------------------------------------------------------- # Mimick the header function. # my $self = shift; $self = $self->class_new unless ref $self; my %p = (ref($_[0]) eq 'HASH') ? %{$_[0]} : ( @_ % 2 ) ? () : @_; my @headers; # Don't print headers twice unless -force'd. return '' if not delete $p{-force} and $PRINTED_HEAD; # Start by adding NPH headers if requested. if ($self->{nph} || $p{-nph}) { if ($p{-url}) { push @headers, "HTTP/1.0 302 Moved"; } else { my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; push @headers, "$protocol 200 OK" unless ($MOD_PERL); } } delete $p{-nph}; # If requested, add a "Pragma: no-cache" if requested if ($p{'no-cache'} or $p{'-no-cache'}) { delete @p{qw/no-cache -no-cache/}; require GT::Date; push @headers, "Expires: Tue, 25 Jan 2000 12:00:00 GMT", "Last-Modified: " . GT::Date::date_get_gm(time, "%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% GMT"), "Cache-Control: no-cache", "Pragma: no-cache"; } # Add any cookies, we accept either an array of cookies # or a single cookie. my $add_date = 0; my $cookies = 0; my $container = delete($p{-cookie}) || ''; require GT::CGI::Cookie if $container; if (ref $container and UNIVERSAL::isa($container, 'GT::CGI::Cookie')) { my $c = $container->cookie_header; push @headers, $c; $add_date = 1; $cookies++; } elsif (ref $container eq 'ARRAY') { foreach my $cookie (@$container) { next unless (defined $cookie and (ref $cookie eq 'GT::CGI::Cookie')); push @headers, $cookie->cookie_header; $add_date = 1; $cookies++; } } elsif ($container) { $self->error('INVALIDCOOKIE', 'WARN', $container); } # Print expiry if requested. if (defined(my $expires = delete $p{-expires})) { require GT::CGI::Cookie; my $date = GT::CGI::Cookie::_format_date(' ', $expires); unless ($date) { $self->error('INVALIDDATE', 'WARN', $expires); } else { push @headers, "Expires: $date"; $add_date = 1; } } # Add a Date header if we printed an expires tag or a cookie tag. if ($add_date) { require GT::CGI::Cookie; my $now = GT::CGI::Cookie::_format_date (' '); push @headers, "Date: $now"; } # Add Redirect Header. my $iis_redirect; if (my $url = delete $p{-url}) { if ($cookies and $ENV{SERVER_SOFTWARE} =~ /IIS/i) { $iis_redirect = $url; } else { push @headers, "Location: $url"; } } # Add the Content-type header. my $type = @_ == 1 && !ref($_[0]) ? $_[0] : delete($p{-type}) || 'text/html'; push @headers, "Content-type: $type"; # Add any custom headers. foreach my $key (keys %p) { $key =~ /^\s*-?(.+)/; push @headers, escape(ucfirst $1) . ": " . (ref $p{$key} eq 'SCALAR' ? ${$p{$key}} : escape($p{$key})); } $PRINTED_HEAD = 1; my $headers = join(CRLF, @headers) . CRLF . CRLF; # Fun hack for IIS if ($iis_redirect) { $iis_redirect =~ y/;/&/; # You can't have semicolons in a meta http-equiv tag. return $headers . <Document Moved END_OF_HTML } return $headers; } $COMPILE{redirect} = __LINE__ . <<'END_OF_SUB'; sub redirect { #------------------------------------------------------------------------------- # Print a redirect header. # my $self = shift; $self = $self->class_new unless ref $self; my (@headers, $url); if (@_ == 0) { return $self->header({ -url => $self->self_url }); } elsif (@_ == 1) { return $self->header({ -url => shift }); } else { my $opts = ref $_[0] eq 'HASH' ? shift : {@_}; $opts->{'-url'} ||= $opts->{'-URL'} || $self->self_url; return $self->header($opts); } } END_OF_SUB $COMPILE{unescape} = __LINE__ . <<'END_OF_SUB'; sub unescape { #-------------------------------------------------------------------------------- # returns the url decoded string of the passed argument # shift if defined $_[1] and UNIVERSAL::isa($_[0], __PACKAGE__); my $todecode = shift; return unless defined $todecode; $todecode =~ tr/+/ /; # pluses become spaces $todecode =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge; return $todecode; } END_OF_SUB $COMPILE{escape} = __LINE__ . <<'END_OF_SUB'; sub escape { #-------------------------------------------------------------------------------- # return the url encoded string of the passed argument # shift if defined $_[1] and UNIVERSAL::isa($_[0], __PACKAGE__); my $toencode = shift; return unless defined $toencode; $toencode =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg; return $toencode; } END_OF_SUB $COMPILE{html_escape} = __LINE__ . <<'END_OF_SUB'; sub html_escape { #-------------------------------------------------------------------------------- # Return the string html_escaped. # shift if defined $_[1] and UNIVERSAL::isa($_[0], __PACKAGE__); my $toencode = shift; return unless (defined $toencode); if (ref($toencode) eq 'SCALAR') { $$toencode =~ s/&/&/g; $$toencode =~ s//>/g; $$toencode =~ s/"/"/g; } else { $toencode =~ s/&/&/g; $toencode =~ s//>/g; $toencode =~ s/"/"/g; } return $toencode; } END_OF_SUB $COMPILE{html_unescape} = __LINE__ . <<'END_OF_SUB'; sub html_unescape { #-------------------------------------------------------------------------------- # Return the string html unescaped. # shift if defined $_[1] and UNIVERSAL::isa($_[0], __PACKAGE__); my $todecode = shift; return unless (defined $todecode); if (ref ($todecode) eq 'SCALAR') { $$todecode =~ s/<//g; $$todecode =~ s/"/"/g; $$todecode =~ s/&/&/g; } else { $todecode =~ s/<//g; $todecode =~ s/"/"/g; $todecode =~ s/&/&/g; } return $todecode; } END_OF_SUB $COMPILE{self_url} = __LINE__ . <<'END_OF_SUB'; sub self_url { # ------------------------------------------------------------------- # Return full URL with query options as CGI.pm # return $_[0]->url ( query_string => 1, absolute => 1 ); } END_OF_SUB $COMPILE{url} = __LINE__ . <<'END_OF_SUB'; sub url { # ------------------------------------------------------------------- # Return the current url. Can be called as GT::CGI->url() or $cgi->url(). # my $self = shift; $self = $self->class_new unless ref $self; $FORM_PARSED or $self->load_data(); my $opts = $self->common_param(@_); my $absolute = exists $opts->{absolute} ? $opts->{absolute} : 0; my $query_string = exists $opts->{query_string} ? $opts->{query_string} : 1; my $path_info = exists $opts->{path_info} ? $opts->{path_info} : 0; my $remove_empty = exists $opts->{remove_empty} ? $opts->{remove_empty} : 0; if ($opts->{relative}) { $absolute = 0; } my $url = ''; my $script = $ENV{SCRIPT_NAME} || $0; my ($path, $prog) = $script =~ m,^(.+?)[/\\]?([^/\\]*)$,; if ($absolute) { my ($protocol, $version) = split ('/', $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'); $url = lc $protocol . "://"; my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME} || ''; $url .= $host; $path =~ s,^[/\\]*|[/\\]*$,,g; $url .= "/$path/"; } $prog =~ s,^[/\\]*|[/\\]*$,,g; $url .= $prog; if ($path_info and $ENV{PATH_INFO}) { if (defined $ENV{SERVER_SOFTWARE} && ($ENV{SERVER_SOFTWARE} =~ /IIS/)) { $ENV{PATH_INFO} =~ s,$ENV{SCRIPT_NAME},,; } $url .= $ENV{PATH_INFO}; } if ($query_string) { my $qs = $self->query_string( remove_empty => $remove_empty ); if ($qs) { $url .= "?" . $qs; } } return $url; } END_OF_SUB $COMPILE{query_string} = __LINE__ . <<'END_OF_SUB'; sub query_string { # ------------------------------------------------------------------- # Returns the query string url escaped. # my $self = shift; $self = $self->class_new unless ref $self; $FORM_PARSED or $self->load_data(); my $opts = $self->common_param(@_); my $qs = ''; foreach my $key (keys %{$self->{params}}) { my $esc_key = escape($key); foreach my $val (@{$self->{params}->{$key}}) { next if ($opts->{remove_empty} and ($val eq '')); $qs .= $esc_key . "=" . escape($val) . ";"; } } $qs and chop $qs; $qs ? return $qs : return ''; } END_OF_SUB sub parse_str { #-------------------------------------------------------------------------------- # parses a query string and add it to the parameter list # my $self = shift; for (split /[;&]/, shift) { /([^=]+)=(.*)/ or next; my ($key, $val) = (unescape($1), unescape($2)); # Need to remove cr's on windows. if ($^O eq 'MSWin32') { $key =~ s/\r\n/\n/g; $val =~ s/\r\n/\n/g; } push @{$self->{params}->{$key}}, $val; } } 1; __END__ =head1 NAME GT::CGI - a lightweight replacement for CGI.pm =head1 SYNOPSIS use GT::CGI; my $in = new GT::CGI; foreach my $param ($in->param) { print "VALUE: $param => ", $in->param($param), "\n"; } use GT::CGI qw/-no_parse_buttons/; =head1 DESCRIPTION GT::CGI is a lightweight replacement for CGI.pm. It implements most of the functionality of CGI.pm, with the main difference being that GT::CGI does not provide a function-based interface (with the exception of the escape/unescape functions, which can be called as either function or method), nor does it provide the HTML functionality provided by CGI.pm. The primary motivation for this is to provide a CGI module that can be shipped with Gossamer products, not having to depend on a recent version of CGI.pm being installed on remote servers. The secondary motivation is to provide a module that loads and runs faster, thus speeding up Gossamer products. Credit and thanks goes to the author of CGI.pm. A lot of the code (especially file upload) was taken from CGI.pm. =head2 param - Accessing form input. Can be called as either a class method or object method. When called with no arguments a list of keys is returned. When called with a single argument in scalar context the first (and possibly only) value is returned. When called in list context an array of values is returned. When called with two arguments, it sets the key-value pair. =head2 header() - Printing HTTP headers Can be called as a class method or object method. When called with no arguments, simply returns the HTTP header. Other options include: =over 4 =item -force => 1 Force printing of header even if it has already been displayed. =item -type => 'text/plain' Set the type of the header to something other then text/html. =item -cookie => $cookie Display any cookies. You can pass in a single GT::CGI::Cookie object, or an array of them. =item -nph => 1 Display full headers for nph scripts. =back If called with a single argument, sets the Content-Type. =head2 redirect - Redirecting to new URL. Returns a Location: header to redirect a user. =head2 cookie - Set/Get HTTP Cookies. Sets or gets a cookie. To retrieve a cookie: my $cookie = $cgi->cookie ('key'); my $cookie = $cgi->cookie (-name => 'key'); or to retrieve a hash of all cookies: my $cookies = $cgi->cookie; To set a cookie: $c = $cgi->cookie (-name => 'foo', -value => 'bar') You can also specify -expires for when the cookie should expire, -path for which path the cookie valid, -domain for which domain the cookie is valid, and -secure if the cookie is only valid for secure sites. You would then set the cookie by passing it to the header function: print $in->header ( -cookie => $c ); =head2 url - Retrieve the current URL. Returns the current URL of the script. It defaults to display just the script name and query string. Options include: =over 4 =item absolute => 1 Return the full URL: http://domain/path/to/script.cgi =item relative => 1 Return only the script name: script.cgi =item query_string => 1 Return the query string as well: script.cgi?a=b =item path_info => 1 Returns the path info as well: script.cgi/foobar =item remove_empty => 0 Removes empty query= from the query string. =back =head2 get_hash - Return all form input as hash. This returns the current parameters as a hash. Any values that have the same key will be returned as an array reference of the multiple values. =head2 escape - URL escape a string. Returns the passed in value URL escaped. Can be called as class method or object method. =head2 unescape - URL unescape a string. Returns the passed in value URL un-escaped. Can be called as class method or object method. =head2 html_escape - HTML escape a string Returns the passed in value HTML escaped. Translates &, <, > and " to their html equivalants. =head2 html_unescape - HTML unescapes a string Returns the passed in value HTML unescaped. =head1 DEPENDENCIES Note: GT::CGI depends on L and L, and if you are performing file uploads, GT::CGI::MultiPart, GT::CGI::Fh, and L. The ability to set cookies requires GT::CGI::Cookie. =head1 COPYRIGHT Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved. http://www.gossamer-threads.com/ =head1 VERSION Revision: $Id: CGI.pm,v 1.102 2002/05/22 00:58:47 jagerman Exp $ =cut private/lib/GT/TempFile.pm0100644000076400010020000001342607453737207014200 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::TempFile # Author : Scott Beck # $Id: TempFile.pm,v 1.33 2002/04/07 03:35:35 jagerman Exp $ # # Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: # Implements a tempfile. # package GT::TempFile; # =================================================================== # Pragmas use strict; use vars qw/@ISA $ERRORS $VERSION $DEBUG $TMP_DIR @POSS_TMP_DIRS $PREFIX $FH $ATTRIBS %OBJECTS/; use bases 'GT::Base' => ':all'; $VERSION = sprintf "%d.%03d", q$Revision: 1.33 $ =~ /(\d+)\.(\d+)/; sub find_tmpdir { # ------------------------------------------------------------------- # Sets the tmpdir. # @POSS_TMP_DIRS = ('/usr/tmp', '/var/tmp', 'c:/temp', '/tmp', '/temp', '/sys$scratch', '/WWW_ROOT', 'c:/windows/temp', 'c:/winnt/temp'); unshift(@POSS_TMP_DIRS,(eval { (getpwuid($<))[7] }) . '/tmp') unless ($^O =~ /Win|Mac/); unshift(@POSS_TMP_DIRS, $ENV{TMPDIR}) if (exists $ENV{TMPDIR}); unshift(@POSS_TMP_DIRS, $ENV{TEMP}) if (exists $ENV{TEMP}); unshift(@POSS_TMP_DIRS, $ENV{TMP}) if (exists $ENV{TMP}); unshift(@POSS_TMP_DIRS, $ENV{windir} . '/temp') if (exists $ENV{windir}); unshift(@POSS_TMP_DIRS, $ENV{GT_TMPDIR}) if (exists $ENV{GT_TMPDIR}); foreach my $dir (@POSS_TMP_DIRS) { next unless ($dir); if (-d $dir and -w _ and -x _) { $TMP_DIR = $dir; last; } } $TMP_DIR ||= '.'; return $TMP_DIR; } sub init { # ------------------------------------------------------------------- # Create a new tempfile. # $TMP_DIR ||= find_tmpdir(); my $self = bless {}, 'GT::TempFile::Tmp'; $self->reset; # Backwards compatibility if ( @_ == 2 and not ref( $_[1] ) ) { ( $self->{tmp_dir} ) = $_[1]; } elsif ( @_ > 1 ) { $self->set( @_[1 .. $#_] ); } my $dir = $self->{tmp_dir} || $TMP_DIR; my $count = substr(time, -4) . int(rand(10000)); my $filename = ''; # Directory for locking my $lock_dir = "$dir/$self->{prefix}GT_TempFile_lock"; # W need to create the directory my $safety = 0; until ( mkdir( $lock_dir, 0777 ) ) { # If we wait 10 seconds and still no lock we assume the lockfile is stale if ( $safety++ > 10 ) { rmdir $lock_dir or $self->fatal( 'RMDIR', $lock_dir, "$!" ); } sleep 1; } # Now lets get our temp file for (1 .. 20) { $filename = "$dir/$self->{prefix}GTTemp$count"; last if (! -f $filename); $count++; } # If the open fails we need to remove the lockdir if ( !open( FH, ">$filename" ) ) { rmdir $lock_dir or $self->fatal( 'RMDIR', $lock_dir, "$!" ); $self->fatal( 'WRITEOPEN', $filename, "$!" ); } close FH; # All done searching for a temp file, now release the directory lock rmdir $lock_dir or $self->fatal( 'RMDIR', $lock_dir, "$!" ); ($filename =~ /^(.+)$/) and ($filename = $1); # Detaint. $self->{filename} = $filename; $_[0] = bless \$filename, 'GT::TempFile'; $OBJECTS{$_[0]} = $self; $self->debug("New tmpfile created ($filename).") if ($self->{_debug}); } sub as_string { # ------------------------------------------------------------------- # Backwards compatibility my ( $self ) = @_; return $$self; } sub DESTROY { # ------------------------------------------------------------------- my $obj = shift; my $self = $OBJECTS{$obj}; $self->debug ("Deleteing $self->{filename}") if ($self->{_debug}); # unlink the file if they wanted it deleted if ( $self->{destroy} ) { unless ( unlink $self->{filename} ) { $self->debug("Unable to remove temp file: $self->{filename} ($!)") if ($self->{_debug}); } } delete $OBJECTS{$obj}; } package GT::TempFile::Tmp; use bases 'GT::Base' => ''; use vars qw/$ATTRIBS $ERRORS $DEBUG/; $ATTRIBS = { prefix => '', destroy => 1, tmp_dir => undef, }; $ERRORS = { SAFETY => "Safety reached while trying to create lock directory %s, (%s)" }; $DEBUG = 0; 1; __END__ =head1 NAME GT::TempFile - implements a vary simple temp file. =head1 SYNOPSIS my $file = new GT::TempFile; open (FILE, "> $$file"); print FILE "somedata"; close FILE; =head1 DESCRIPTION GT::TempFile implements a very simple temp file system that will remove itself once the variable goes out of scope. When you call new, it creates a random file name and looks for a tmp directory. What you get back is an object that when dereferenced is the file name. You can also pass in a temp dir to use: my $file = new GT::Tempfile '/path/to/tmpfiles'; Other option you may use are: my $file = new GT::TempFile( destroy => 1, prefix => '', tmp_dir => '/tmp' ); When the object is destroyed, it automatically unlinks the temp file unless you specify I => 0. I will be prepended to the start of all temp files created and the lock directory that is created. It is used to keep programs using the tempfile module that do not have the temp files destroyed from clashing. I is the same as calling new with just one argument, it is the directory where files will be stored. TempFile picks a temp directory based on the following: 1. ENV{GT_TMPDIR} 2. ~/tmp 3. ENV{TMPDIR}, ENV{TEMP}, ENV{TMP} 4. /usr/tmp, /var/tmp, c:/temp, /tmp, /temp, /WWW_ROOT, c:/windows/temp, c:/winnt/temp =head1 COPYRIGHT Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved. http://www.gossamer-threads.com/ =head1 VERSION Revision: $Id: TempFile.pm,v 1.33 2002/04/07 03:35:35 jagerman Exp $ =cut private/lib/GT/Tar.pm0100644000076400010020000010715007453737207013217 0ustar alexcvs# ================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::Tar # Author: Scott Beck # $Id: Tar.pm,v 1.46 2002/04/07 03:35:35 jagerman Exp $ # # Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved. # ================================================================== # # Description: A general purpose taring and untaring module. # package GT::Tar; # ================================================================== # Pragmas use vars qw/$DEBUG $ERRORS $FAKE_GETPWUID $HAVE_GZIP $FAKE_GETGRGID $FH/; use strict; # System modules use Fcntl; # Contants use constant BLOCK => 4096; use constant FILE => 0; use constant HARDLINK => 1; use constant SYMLINK => 2; use constant CHARDEV => 3; use constant BLOCKDEV => 4; use constant DIR => 5; use constant FIFO => 6; use constant SOCKET => 8; use constant UNKNOWN => 9; # Internal modules use GT::Base; # Globals $DEBUG = 0; @GT::Tar::ISA = qw{GT::Base}; $ERRORS = { OPEN => "Could not open %s. Reason: %s", READ => "There was an error reading from %s. Expected to read %s bytes, but only got %s.", BINMODE => "Could not binmode %s. Reason: %s", BADARGS => "Bad arguments passed to %s. Reason: %s", CHECKSUM => "Checksum Error parsing tar file. Most likely this is a corrupt tar.\nHeader: %s\nChecksum: %s\nFile: %s\n", NOBODY => "File '%s' does not have a body!", CANTFIND => "Unable to find a file named: '%s' in tar archive.", CHMOD => "Could not chmod %s, Reason: %s", DIRFILE => "'%s' exists and is a file. Cannot create directory", MKDIR => "Could not mkdir %s, Reason: %s", RENAME => "Unable to rename temp file: '%s' to tar file '%s'. Reason: %s", NOGZIP => "Compress::Zlib module is required to work with .tar.gz files." }; $FAKE_GETPWUID = "unknown" if ($^O eq 'MSWin32'); $FAKE_GETGRGID = "unknown" if ($^O eq 'MSWin32'); $HAVE_GZIP = eval { local $SIG{__DIE__}; require Compress::Zlib; 1; } ? 1 : 0; $FH = 0; sub new { # ------------------------------------------------------------------------------ # GT::Tar->new('/path/to/new/tar.tar'); # -------------------------------------- # Constructor for GT::Tar. Call this method to create a new archive. # To do anything with an existing archive call GT::Tar->open. # my $this = shift; my $class = ref $this || $this; my $self = bless {}, $class; my $opt = {}; if (@_ == 1) { $opt->{io} = shift } else { $opt = $self->common_param(@_); } $self->{_debug} = exists $opt->{debug} ? $opt->{debug} : $DEBUG; $opt->{io} or return $self->error("BADARGS", "FATAL", "new()", "No output archive passed in"); $opt->{io} =~ /^(.+)$/; my $file = $1; # If it's a gz file, store the name in gz_file, and work off a temp file. if ($file =~ /\.t?gz$/) { $HAVE_GZIP or return $self->error('NOGZIP', 'WARN'); require GT::TempFile; my $tmpfile = new GT::TempFile; $self->{file} = $$tmpfile; # Filename of ungzipped tar file. $self->{gz_file} = $file; # Filename of gzipped file. $self->{tmp_file} = $tmpfile; # Don't unlink it till the object is destroyed. } else { $self->{file} = $file; } $self->{io} = _gen_fh(); sysopen $self->{io}, $self->{file}, O_CREAT|O_TRUNC|O_RDWR or return $self->error("OPEN", "FATAL", $self->{file}, "($!)"); binmode $self->{io} or return $self->error("BINMODE", "FATAL", $self->{file}, "($!)"); select((select($self->{io}), $| = 1)[0]); $self->{parsed} = 0; $self->{new_tar} = 1; return $self; } sub open { # ------------------------------------------------------------------------------ # GT::Tar->open('/path/to/tar.tar'); # ----------------------------------- # Opens the tar specified by the first argument for reading and calls # $obj->parse to parse the contents. # Returns a new GT::Tar object. # my $this = shift; my $class = ref $this || $this; my $self = bless {}, $class; my $opt = {}; if (@_ == 1) { $opt->{io} = shift } else { $opt = $self->common_param(@_); } $self->{_debug} = exists $opt->{debug} ? $opt->{debug} : $DEBUG; $opt->{io} or return $self->error("BADARGS", "FATAL", "open()", "No input archive passed in"); $opt->{io} =~ /^(.+)$/; my $file = $1; # If it's a gz file, uncompress it to a temp file and work off that. if ($file =~ /\.t?gz$/) { $HAVE_GZIP or return $self->error('NOGZIP', 'WARN'); require GT::TempFile; my $tmpfile = new GT::TempFile; $self->debug("Decompressing gz file to temp file: $$tmpfile") if ($self->{_debug}); open(FH, "> $$tmpfile") or return $self->error('OPEN', 'WARN', $$tmpfile, "$!"); binmode FH; my $gz = Compress::Zlib::gzopen($file, 'rb') or return $self->error('OPEN', 'WARN', $file, $Compress::Zlib::gzerrno); my $line; while ($gz->gzreadline($line)) { print FH $line; } close FH; $gz->gzclose; $self->{file} = $$tmpfile; # Filename of open ungzipped tar file. $self->{gz_file} = $file; # Filename of original gzipped file. $self->{tmp_file} = $tmpfile; # Don't unlink it till the object is destroyed. } else { $self->{file} = $file; } $self->{io} = _gen_fh(); $self->debug("Opening $file") if ($self->{_debug}); sysopen $self->{io}, $self->{file}, O_RDONLY or return $self->error("OPEN", "WARN", $self->{file}, "($!)"); binmode $self->{io} or return $self->error("BINMODE", "WARN", "($!)"); select((select($self->{io}), $| = 1)[0]); my $parts = $self->parse; defined $parts or return; $self->{new_tar} = 0; return $self; } sub close_tar { # ------------------------------------------------------------------------------ # Closes the tar file. # my $self = shift; $self->{parsed} = 0; close $self->{io} if ($self->{io} and fileno($self->{io})); } sub DESTROY { my $self = shift; $self->close_tar; } sub parse { # ------------------------------------------------------------------------------ # Modified from code in Archive::Tar # Untar a file, specified by first argument to directories, specified in third # argument, and set the path to perl, specified in second argument, to all .pl # and .cgi files # my $self = shift; $self->{parts} = []; my ($head, $msg); my $tar = $self->{io} or return $self->error("BADARGS", "FATAL", "parse", "An IO must be defined to parse"); seek($tar, 0, 0); read($tar, $head, 512); READLOOP: while (length($head) == 512) { # End of archive last READLOOP if $head eq "\0" x 512; # Apparently this should really be two blocks of 512 zeroes, but GNU tar # sometimes gets it wrong. See comment in the source code (tar.c) to GNU cpio. my $file = GT::Tar::Parts->format_read($head); $self->debug("Looking at $file->{name}") if ($self->{_debug}); substr($head, 148, 8) = " "; if (unpack("%16C*", $head) != $file->{chksum}) { return $self->error('CHECKSUM', 'WARN', $head, $file->{chksum}, $file->{name}); } if ($file->{type} == FILE) { # Find the start and the end positions in the tar file for the body of the tar # part my $start = tell $tar; seek($tar, $file->{size}, 1); $file->body([$tar, $start]); # Seek off trailing garbage. my $block = $file->{size} & 0x01ff ? ($file->{size} & ~0x01ff) + 512 : $file->{size}; my $to_read = $block - $file->{size}; if ($to_read) { seek($tar, $to_read, 1) } } # Guard against tarfiles with garbage at the end last READLOOP if $file->{name} eq ''; push(@{$self->{parts}}, $file); } continue { read($tar, $head, 512) } $self->{parsed} = 1; seek($tar, 0, 0); return wantarray ? @{$self->{parts}} : $self->{parts}; } sub untar { # ----------------------------------------------------------------------------- # $obj->untar(\&code); # --------------------- # Untars tar file specified in $obj->open and runs callback for each entry in # the tar file. Passed a parts object to that callback. # # $obj->untar; # ------------ # Same a above but no callback. # # GT::Tar->untar('/path/to/tar.tar', \&code); # -------------------------------------------- # Untars file specified by the first argument and runs callback in second # argument. # # GT::Tar->untar('/path/to/tar.tar'); # ------------------------------------ # Untars tar file specified by first argument. # my $self = (ref $_[0] eq __PACKAGE__) ? shift : shift()->open( shift() ); my $callback = pop; if ($callback) { (ref $callback eq 'CODE') or return $self->error("BADARGS", "FATAL", "untar", "Callback that was passed in was not a code ref"); } if (!$self->{parsed}) { $self->debug("Parsing tar file") if ($self->{_debug}); $self->parse or return; } else { $self->debug("Already parsed") if ($self->{_debug}); } for (@{$self->{parts}}) { if ($callback) { $callback->($_); } else { $_->write; } } return $self; } sub tar { # ------------------------------------------------------------------------------ # $obj->tar; # ---------- # Creates tar file that was specified in $obj->new with files that were added # using $obj->add. # # GT::Tar->tar('/path/to/tar.tar', @files); # ------------------------------------------ # Creates tar file specified by the first argument with the files specified # by the remaining arguments. # my $self; if (ref $_[0] eq __PACKAGE__) { $self = shift; } else { my $class = shift; $self = $class->new( io => shift ); $self->add(@_) if (@_); } $self->write; } sub write { # ------------------------------------------------------------------------------ # $obj->write; # ------------ # Creates all the files that are internally in the parts objects. You add # files to parts by calling $obj->add -or- by calling $obj->open on an # existing tar file. This is similar to untar. # my $self = shift; my ($out, $rename, $filename); # Working off an existing tar file. if (! $self->{new_tar}) { if (@_) { $filename = shift; # If we have a new .tar.gz file, we need to write it to a tmp .tar first. if ($filename =~ /\.t?gz$/) { $HAVE_GZIP or return $self->error('NOGZIP', 'WARN'); $self->{gz_file} = $filename; undef $filename; } } if (! $filename) { require GT::TempFile; my $tmp = new GT::TempFile; $filename = $$tmp; $rename = $self->{file}; } $out = _gen_fh(); sysopen $out, $filename, O_CREAT|O_TRUNC|O_RDWR or return $self->error("OPEN", "WARN", $filename, "($!)"); binmode $out or return $self->error('BINMODE', 'FATAL', $filename, "($!)"); } # Working off a new tar file. else { $out = $self->{io}; seek($out, 0, 0); } # Unbuffer output select((select($out), $| = 1)[0]); foreach my $entry (@{$self->{parts}}) { my $head = $entry->format_write; print $out $head; my $save = tell $out; if ($entry->type == FILE) { my $bh; my $body = $entry->body or return $self->error('NOBODY', 'WARN', $entry->name); my $ref = ref $body; if ($ref eq 'GLOB' and fileno $body) { my $fh = $body; my $pos = tell $fh; binmode $fh; while (read $fh, $_, BLOCK) { print $out $_; } seek($fh, $pos, 0); } elsif ($ref eq 'ARRAY') { my ($reads, $rem, $data, $pos); my ($fh, $start) = @{$body}; $pos = tell $fh; seek($fh, $start, 0); binmode $fh; $reads = int($entry->{size} / BLOCK); $rem = $entry->{size} % BLOCK; for (1 .. $reads) { my $read = read($fh, $data, BLOCK); ($read == BLOCK) or return $self->error("READ", "WARN", join(',' => @{$body}), BLOCK, $read); print $out $data; } if ($rem) { my $read = read($fh, $data, $rem); ($read == $rem) or return $self->error("READ", "WARN", join(',' => @{$body}), $rem, $read); print $out $data; } seek($fh, $pos, 0); } elsif ($ref eq 'SCALAR') { CORE::open F, ${$body} or return $self->error('READOPEN', 'WARN', ${$body}, "($!)"); binmode F; while (read F, $_, BLOCK) { print $out $_; } close F; } else { print $out $body; } my $size = $entry->{size} & 511; if ($size) { print $out ("\0" x (512 - $size)); } $entry->body( [ $out, $save ] ); } } print $out ("\0" x 1024); # Copy the temp file over to the original file (can't rename across filesystems). if ($rename and !$self->{gz_file}) { seek($out, 0, 0); $self->{io} = _gen_fh(); sysopen($self->{io}, $rename, O_CREAT|O_TRUNC|O_RDWR) or return $self->error("OPEN", "WARN", $rename, "($!)"); binmode $self->{io}; while (read($out, my $buffer, BLOCK)) { print {$self->{io}} $buffer; } seek($self->{io}, 0, 0); # Need to set the parts to the new file handle. foreach my $entry (@{$self->{parts}}) { if ($entry->type == FILE) { $entry->{body}->[0] = $self->{io}; } } close $out; $out = $self->{io}; $self->{file} = $rename; unlink $filename or return $self->error('UNLINK', 'WARN', $filename, "($!)"); } # Recompress if it was a .gz file. if ($self->{gz_file}) { $HAVE_GZIP or return $self->error('NOGZIP', 'WARN'); seek($out, 0, 0); my $gz = Compress::Zlib::gzopen($self->{gz_file}, 'wb') or return $self->error('OPEN', 'WARN', $self->{gz_file}, $Compress::Zlib::gzerrno); while (read($out, my $buffer, BLOCK)) { $gz->gzwrite($buffer); } $gz->gzclose(); seek($out, 0, 0); } return 1; } sub extract { # ------------------------------------------------------------------------------ # $obj->extract(@list); # ---------------------- # $obj->extract(\@list); # ----------------------- # Extracts only the files specified in @list from the working tar file. No # files are extracted if none are in memory. # my $self = shift; my %files = map { $_ => 1 } ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_; my $num = '0E0'; foreach my $entry (@{$self->{parts}}) { next unless (exists $files{$entry->{name}}); $entry->write; $num++; } return $num; } sub add_file { # ------------------------------------------------------------------------------ # $obj->add_file(@list); # ------------------ # $obj->add_file(\@list); # ------------------- # Adds the files specified in @list to the in-memory archive. # my $self = shift; my @files = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_; while (my $file = shift @files or @files) { next if not defined $file; my ($mode, $nlnk, $uid, $gid, $rdev, $size, $mtime, $type, $linkname); $self->debug("Looking at $file") if ($self->{_debug}); if (($mode, $nlnk, $uid, $gid, $rdev, $size, $mtime) = (lstat $file)[2 .. 7, 9]) { $linkname = ""; $type = filetype($file); $linkname = readlink $file if ($type == SYMLINK); if ($type == DIR) { my $dir = _gen_fh(); opendir $dir, $file or return $self->error("OPEN", "WARN", "Can't add directory '$file'", "($!)"); push(@files, map { $file . '/' . $_ } grep !/^\.\.?$/, readdir $dir); closedir $dir; } my $part = GT::Tar::Parts->new( { name => $file, mode => $mode, uid => $uid, gid => $gid, size => $size, mtime => ($mtime | 0), chksum => " ", magic => "ustar", version => "", type => $type, linkname => $linkname, devmajor => 0, # We don't handle this yet devminor => 0, # We don't handle this yet uname => ($FAKE_GETPWUID || scalar getpwuid($uid)), gname => ($FAKE_GETGRGID || scalar getgrgid($gid)), prefix => "", } ); if ($type == FILE) { $self->debug("Adding $file to as body") if ($self->{_debug}); $part->body(\$file); } push(@{$self->{parts}}, $part); } else { $self->debug("Could not stat file '$file'"); } } return wantarray ? @{$self->{parts}} : $self->{parts}; } sub remove_file { # ------------------------------------------------------------------- # Takes a string and removes the file from the tar. # my ($self, $filename) = @_; return unless (defined $filename); @{$self->{parts}} = grep { $_->{name} ne $filename } @{$self->{parts}}; } sub get_file { # ------------------------------------------------------------------- # Returns the file object of a given file name. # my ($self, $filename) = @_; return unless (defined $filename); my @files = grep { $_->{name} eq $filename } @{$self->{parts}}; if (! @files) { return $self->error('CANTFIND', 'WARN', $filename); } return wantarray ? @files : shift @files; } sub add_data { # ------------------------------------------------------------------- # $obj->add_newfile( { ... } ); # ------------------------------ # Adds a file from a hash ref of part attributes. # my $self = shift; my $part = @_ > 1 ? {@_} : shift; ref $part eq 'HASH' or return $self->error('BADARGS', 'FATAL', "Usage: \$obj->add_newfile( part options )"); defined $part->{name} or return $self->error('BADARGS', 'FATAL', "You must supply a file name."); defined $part->{body} or return $self->error('BADARGS', 'FATAL', "You must supply a body for the file."); if (ref $part->{body}) { if (fileno $part->{body}) { local $/; my $fh = $part->{body}; $part->{body} = <$fh>; } else { return $self->error('BADARGS', 'FATAL', "You must supply either a scalar or a file handle to body"); } } my $file = GT::Tar::Parts->new({ name => $part->{name}, mode => defined $part->{mode} ? $part->{mode} : 0666 & (0777 - umask), uid => defined $part->{uid} ? $part->{uid} : $>, gid => defined $part->{gid} ? $part->{gid} : (split(/ /,$)))[0], size => length $part->{body}, mtime => defined $part->{mtime} ? $part->{mtime} : time, chksum => " ", magic => "ustar", version => "00", type => FILE, linkname => '', devmajor => 0, # We don't handle this yet devminor => 0, # We don't handle this yet uname => ($FAKE_GETPWUID || scalar getpwuid(defined $part->{uid} ? int($part->{uid}) : $>)), gname => ($FAKE_GETGRGID || scalar getgrgid(defined $part->{gid} ? int($part->{gid}) : (split(/ /,$)))[0])), prefix => "" }); $file->body($part->{body}); push(@{$self->{parts}}, $file); return $file; } sub files { # ------------------------------------------------------------------------------ # my @files = $obj->files; # ------------------------ # Returns a list of the part objects that are in the in-memory archive. # Returns an array ref in scalar context. # my @parts = defined $_[0]->{parts} ? @{$_[0]->{parts}} : (); return wantarray ? @parts : \@parts; } sub filetype { # ------------------------------------------------------------------------------ # Internal method. filetype -- Determine the type value for a given file # my $file = shift; return SYMLINK if (-l $file); # Symlink return FILE if (-f _); # Plain file return DIR if (-d _); # Directory return FIFO if (-p _); # Named pipe return SOCKET if (-S _); # Socket return BLOCKDEV if (-b _); # Block special return CHARDEV if (-c _); # Character special return UNKNOWN; # Something else (like what?) } sub _gen_fh { # ------------------------------------------------------------------- # Return a file handle symbol. # no strict 'refs'; return *{"FH" . $FH++}; } package GT::Tar::Parts; # ================================================================== # Pragmas use vars qw/$DEBUG $ERRORS $ATTRIBS $ERROR_MESSAGE/; use strict; # System modules use Fcntl; # Globals $DEBUG = 0; @GT::Tar::Parts::ISA = qw{GT::Base}; $ATTRIBS = { name => '', mode => '', uid => '', gid => '', size => '', mtime => '', chksum => " ", type => '', linkname => '', magic => "ustar", version => "00", uname => 'unknown', gname => 'unknown', devmajor => 0, # We don't handle this yet devminor => 0, # We don't handle this yet prefix => "", body => undef, set_owner => 1, set_perms => 1, set_time => 1, }; $ERROR_MESSAGE = 'GT::Tar'; sub format_read { # ------------------------------------------------------------------------------ # my $obj = GT::Tar::Parts->format_read($heading); # ------------------------------------------------- # Unpacks the string that is passed in. The string need to be a valid header # from a single entry in a tar file. Return a new object for the Tar part. # You will need to set the body yourself after calling this. # my $head_tainted = pop; my ($head) = $head_tainted =~ /(.+)/; my $tar_unpack_header = 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155'; my $file = {}; ( $file->{name}, $file->{mode}, $file->{uid}, $file->{gid}, $file->{size}, $file->{mtime}, $file->{chksum}, $file->{type}, $file->{linkname}, $file->{magic}, $file->{version}, $file->{uname}, $file->{gname}, $file->{devmajor}, $file->{devminor}, $file->{prefix} ) = unpack($tar_unpack_header, $head); $file->{uid} = oct $file->{uid}; $file->{gid} = oct $file->{gid}; $file->{mode} = oct $file->{mode}; $file->{size} = oct $file->{size}; $file->{mtime} = oct $file->{mtime}; $file->{chksum} = oct $file->{chksum}; $file->{devmajor} = oct $file->{devmajor}; $file->{devminor} = oct $file->{devminor}; $file->{name} = $file->{prefix} . "/" . $file->{name} if $file->{prefix}; $file->{prefix} = ""; $file->{type} = GT::Tar::DIR if $file->{name} =~ m|/$| and $file->{type} == GT::Tar::FILE; return GT::Tar::Parts->new($file); } sub format_write { # ------------------------------------------------------------------------------ # $obj->format_write; # ------------------- # Formats the current objects header for writting to a tar file. # Returns the formatted string. # my $self = shift; my ($tmp, $file, $prefix, $pos); $file = $self->{name}; if (length($file) > 99) { $pos = index $file, "/", (length($file) - 100); next if $pos == -1; # Filename longer than 100 chars! $prefix = substr $file, 0, $pos; $file = substr $file, $pos+1; substr($prefix, 0, -155) = "" if length($prefix) > 154; } else { $prefix = ""; } if ($self->{type} == GT::Tar::DIR and $file !~ m,/$,) { $file .= '/'; } $tmp = pack( 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a5 a3 a32 a32 a8 a8 a155 x12', $file, sprintf("%07o",$self->{mode}), sprintf("%07o",$self->{uid}), sprintf("%07o",$self->{gid}), sprintf("%011o", $self->{type} == GT::Tar::DIR ? 0 : $self->{size}), sprintf("%011o",$self->{mtime}), "", #checksum field - space padded by pack("A8") $self->{type}, $self->{linkname}, $self->{magic}, $self->{version} || ' ', $self->{uname}, $self->{gname}, '', # sprintf("%6o ",$self->{devmajor}), '', # sprintf("%6o ",$self->{devminor}), $prefix ); substr($tmp, 148, 7) = sprintf("%06o\0", unpack("%16C*", $tmp)); return $tmp; } sub body { # ------------------------------------------------------------------------------ # my $path = $obj->body; # ---------------------- # $obj->body(\'/path/to/body'); # $obj->body("My body text."); # ----------------------------- # Sets or gets the path to the body of this tar part. If a scalar ref is # passed in it is considered a path to a file otherwize it is considered a # string to write to the body when write is called. # my ($self, $io) = @_; !$io and return $self->{body}; $self->{body} = $io; my $ref = ref $io; if ($ref eq 'GLOB' and fileno $io) { $self->{size} = (lstat(${$self->{body}}))[7]; } elsif ($ref eq 'SCALAR') { $self->{size} = -s ${$self->{body}}; } elsif (not $ref) { $self->{size} = length $self->{body}; } return $self->{body}; } sub body_as_string { # ------------------------------------------------------------------------------ # my $data = $obj->body_as_string; # -------------------------------- # Returns the body of the file as a string. # my $self = shift; my $data = ''; my $ref = ref $self->{body}; if ($ref eq 'GLOB' and fileno $self->{body}) { my $fh = $self->{body}; my $pos = tell $fh; seek($fh, 0, 0); binmode $fh; local $/; $data = <$fh>; seek($fh, $pos, 0); } elsif ($ref eq 'ARRAY') { my ($fh, $start) = @{$self->{body}}; my $pos = tell $fh; binmode $fh; seek($fh, $start, 0); read($fh, $data, $self->{size}); seek($fh, $pos, 0); } elsif ($ref eq 'SCALAR') { my $fh = _gen_fh(); open $fh, ${$self->{body}} or return $self->error('READOPEN', 'WARN', ${$self->{body}}, "($!)"); binmode $fh; read($fh, $data, -s $fh); close $fh; } else { $data = $self->{body}; } return $data; } sub write { # ------------------------------------------------------------------------------ # $obj->write; # ------------ # Writes this part to disk using the path that is in $obj->body. This function # will recursivlty make the directories needed to create the structure of this # part. # my $self = shift; # For the moment, we assume that all paths in tarfiles are given according to # Unix standards, which they *are*, according to the tar format spec! $self->_write_dir or return; if ($self->{type} == GT::Tar::FILE) { my $out = GT::Tar::_gen_fh(); $self->{name} =~ /^(.+)$/; my $name = $1; open $out, ">$self->{name}" or return $self->error("OPEN", "WARN", $self->{name}, "($!)"); binmode $out or return $self->error("BINMODE", "WARN", "($!)"); my $ref = ref $self->{body}; if ($ref eq 'GLOB' and fileno $self->{body}) { my $fh = $self->{body}; my $pos = tell $fh; binmode $fh; while (read $fh, $_, GT::Tar::BLOCK) { print $out $_; } seek($fh, $pos, 0); } elsif ($ref eq 'ARRAY') { my ($reads, $rem, $data, $pos); my ($fh, $start) = @{$self->{body}}; $pos = tell $fh; seek($fh, $start, 0); binmode $fh; $reads = int($self->{size} / GT::Tar::BLOCK); $rem = $self->{size} % GT::Tar::BLOCK; for (1 .. $reads) { my $read = read($fh, $data, GT::Tar::BLOCK); ($read == GT::Tar::BLOCK) or return $self->error("READ", "WARN", join(',' => @{$self->{body}}), GT::Tar::BLOCK, $read); print $out $data; } if ($rem) { my $read = read($fh, $data, $rem); ($read == $rem) or return $self->error("READ", "WARN", join(',' => @{$self->{body}}), $rem, $read); print $out $data; } seek($fh, $pos, 0); } elsif ($ref eq 'SCALAR') { my $fh = GT::Tar::_gen_sym(); open $fh, ${$self->{body}} or return $self->error('READOPEN', 'WARN', ${$self->{body}}, "($!)"); binmode $fh; while (read $fh, $_, GT::Tar::BLOCK) { print $out $_; } close $fh; } else { print $out $self->{body}; } close $out; $self->debug("Created $self->{name} size $self->{size}") if ($self->{_debug}); } $self->_file_sets; return 1; } sub _recurse_mkdir { # --------------------------------------------------------------------- # Internal method to recursivly make a directory. # my ($self) = @_; my $dir = $self->{name}; my @path = split m|/|, $dir; ($dir =~ m,/$,) or pop(@path); my $go = ''; foreach my $path (@path) { next if $path =~ /^\s*$/; $go .= $path; $go .= '/' unless $go =~ m,/$,; ($go = '/' . $go) if ($dir =~ m,^/, and $go !~ m,^/,); (my $next = $go) =~ s,/$,,; ((-e $next) and (not -d $next)) and return $self->error("DIRFILE", "FATAL", $self->{name}); unless (-d $next) { mkdir($next, 0777) or return $self->error("MKDIR", "WARN", $next, "($!)"); $self->debug("mkdir $next") if ($DEBUG); } } return 1; } sub _write_dir { # ------------------------------------------------------------------------------ # Internal method used to create a directory for a file, or just create a # directory if this is a directory part and the directory does not exist. my $self = shift; if ($self->{type} == GT::Tar::DIR) { ((-e $self->{name}) and (not -d $self->{name})) and return $self->error("DIRFILE", "FATAL", $self->{name}); unless (-d $self->{name}) { $self->_recurse_mkdir or return; } } else { $self->_recurse_mkdir or return; } return 1; } sub _file_sets { # ------------------------------------------------------------------------------ # Internal method to set the file or directory permissions and or onership of # this part. # my $self = shift; # Set the file creation time. if ($self->{set_time}) { utime time, $self->{mtime}, $self->{name}; } # Set the file owner. if ($self->{set_owner}) { $self->debug("chown ($self->{uid},$self->{gid}) $self->{name}") if ($self->{_debug}); chown($self->{uid}, $self->{gid}, $self->{name}) if ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32"); } # Set the permissions (done last in case it makes file readonly) if ($self->{set_perms}) { my ($mode) = sprintf("%lo", $self->{mode}) =~ /(\d{3})$/; $self->debug("chmod $mode, $self->{name}") if ($self->{_debug}); chmod $self->{mode}, $self->{name} or return $self->error("CHMOD", "WARN", $self->{name}, "($!)"); } return 1; } 1; __END__ =head1 NAME GT::Tar - Perl module to manipulate tar files. =head1 SYNOPSIS use GT::Tar; my $tar = GT::Tar->open('foo.tar'); $tar->add_file( '/path/to/file' ); $tar->write; =head1 DESCRIPTION GT::Tar provides an OO intefrace to a tar file. It allows you to create or edit tar files, and if you have Compress::Zlib installed, it allows you to work with .tar.gz files as well! =head2 Creating a tar file To create a tar file, you simply call: my $tar = new GT::Tar; and then to save it: $tar->write('filename.tar'); will save the tar file and any files you have added. =head2 Opening an existing tar file To open a tar file you call: my $tar = GT::Tar->open('/path/to/file.tar') or die "Can't open: $GT::Tar::error"; Note: the tar object keeps an open filehandle to the file, so if you are on windows, you may not be able to manipulate it until you call $tar->close_tar, or the tar object goes out of scope. =head2 Untarring a tar file To untar a tar file, you can simply call: $tar->untar( \&code_ref ); or as a class method GT::Tar->untar('/path/to/tar.tar', \&code_ref ); The code ref is optional. If provided, you will get passed in the a GT::Tar::Part object before the file is extracted. This lets you change the path, or alter any attributes of the file before it is saved to disk. =head2 Adding files to a tar file To add a file: $tar->add_file( '/path/to/file' ); Note, if you add a directory, the tar module will recurse and add all files in that directory. To add a file that isn't saved: $tar->add_data( name => 'Filename', body => 'File body' ); You can pass in either a scalar for the body, or an opened file handle. =head2 Getting a list of files in a tar To get a list of files in a tar: my $files = $tar->files; This returns an array ref of GT::Tar::Part objects. See below for how to access information from a part. Note: if you change a part, it will update the tar file if you save it. =head2 Getting an individual file from a tar If you know the name of the file you want: my $file = $tar->get_file('Filename'); will return a single GT::Tar::Part object. =head2 Removing a file from a tar To remove a file, you need to know the name of it: $tar->remove_file('Filename'); $tar->write; and you need to save it before the change will take affect. =head2 GT::Tar::Part Each file is a separate part object. The part object has the following attributes: name file name mode file permissions uid user id gid group id size file size mtime last modified time type file type body file body You can access or set any of these attributes by just using the attribute name as the method (as it inherits from L). You can also call: $file->write; and the file will be created with the given attributes. Basically untar just foreach's through each of the objects and calls write() on it. =head1 EXAMPLES To create a new tar and add two directories to it, and save it in '/tmp/foo.tar'; my $tar = new GT::Tar; $tar->add_file( '/home/httpd/html' ); $tar->add_file( '/home/backup' ); $tar->write('/tmp/foo.tar'); To open an existing tar file and save all the .pl files in /home/alex. my $tar = GT::Tar->open('files.tar'); my $files = $tar->files; foreach my $file (@$files) { my $name = $file->name; if ($name =~ m,([^/]*\.pl$),) { $file->name( "/home/alex/$1" ); $file->write; } } =head1 COPYRIGHT Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved. http://www.gossamer-threads.com/ =head1 VERSION Revision: $Id: Tar.pm,v 1.46 2002/04/07 03:35:35 jagerman Exp $ =cut private/lib/GT/Template.pm0100644000076400010020000015207107473631604014242 0ustar alexcvs# ==================================================================== # Gossamer Threads Module Library - http://gossamer-threads.com/ # # GT::Template # Author: Jason Rhinelander # $Id: Template.pm,v 2.78 2002/05/25 06:47:32 jagerman Exp $ # # Copyright (c) 1999,2000 Gossamer Threads Inc. All Rights Reserved. # ==================================================================== # # Description: # A module for parsing templates. # package GT::Template; # =============================================================== use 5.004_04; use strict; use GT::Base(); use GT::CGI(); use GT::AutoLoader; use vars qw(@ISA %FILE_CACHE %FILE_CACHE_PRINT $VERSION $DEBUG $ATTRIBS $ERRORS $error $VARS); @ISA = qw/GT::Base/; $VERSION = sprintf "%d.%03d", q$Revision: 2.78 $ =~ /(\d+)\.(\d+)/; $DEBUG = 0; $ATTRIBS = { func_code => undef, heap => undef, root => '.', strict => 1, compress => 0, begin => '<%', end => '%>', escape => 0, print => 0, stream => 0, cache => 1, indent => ' ', dont_save => 0 }; $ERRORS = { NOTEMPLATE => "No template file was specified.", CANTOPEN => "Unable to open template file '%s'. Reason: %s", NOTDIR => "Error: '%s' is not a directory", CANTRUN => "Unable to run compiled template file '%s'. Reason: %s", CANTRUNSTRING => "Unable to run compiled template code '%s' (from string). Reason: %s", CANTDIR => "Unable to create compiled template directory '%s'. Reason: %s", DIRNOTWRITEABLE => "Compiled template directory '%s' is not writeable", LOOPNOTHASH => "Error: Value '%s' for loop variable is not a hash reference", NOSUB => "Error: No subroutine '%s' in '%s'", BADVAR => "Error: Invalid variable name '\$%s' passed to function: %s\:\:%s", CANTLOAD => "Error: Unable to load module: %s. Reason:
%s
", NOTCODEREF => "Error: Variable '%s' is not a code reference", COMPILE => "Error: Unable to compile function: %s. Reason: %s", UNKNOWNTAG => "Unknown Tag: '%s'", TPLINFO_CANT_LOAD => "Unable to read template information file '%s': %s", TPLINFO_CANT_COMPILE => "Unable to compile template information file '%s': %s", TPLINFO_NOT_HASH => "Template information file '%s' does not contain a hash reference (Got: '%s')" }; sub parse { # --------------------------------------------------------------- # Can be called as either a class method or object method. When called as a class # method, we need a new object (can't reuse due to function calls re-using the same # parser). # my $self = ref $_[0] ? shift : (shift->new); my ($template, $vars, $opt, $print) = @_; # The fourth argument should only be used internally. defined $template or exists $opt->{string} or return $self->error(NOTEMPLATE => FATAL => $template); defined $vars or ($vars = {}); defined $opt or ($opt = {}); my $alias = delete $opt->{alias}; # Set print if we were called via parse_print or parse_stream. if (($print and $print == 2) or $self->{stream} or $opt->{stream}) { $print = $self->{print} = $opt->{print} = 2; } elsif ($print or $self->{print} or $opt->{print}) { $print = $self->{print} = $opt->{print} = 1; } $self->{begin} = $opt->{begin} if $opt->{begin}; $self->{end} = $opt->{end} if $opt->{end}; $self->debug_level(delete $opt->{debug_level}) if exists $opt->{debug_level}; # Load the variables used in parsing. (ref $vars eq 'ARRAY') ? $self->load_vars(@$vars) : $self->load_vars($vars); # Load alias used for function calles. (ref $alias eq 'ARRAY') ? $self->load_alias(@$alias) : $self->load_alias($alias) if $alias; # Load the template which can either be a filename, or a string passed in. $self->{root} = $opt->{root} if defined $opt->{root}; if (exists $opt->{string}) { $self->debug("Parsing string '$opt->{string}' with (print => $opt->{print}, compress => $opt->{compress}, strict => $opt->{strict}, escape => $opt->{escape})") if $self->{_debug}; return $self->parse_string($opt->{string}, $opt); } # Look for a template information file my $tplinfo = $self->load_tplinfo($self->{root}); $self->{tplinfo} = $tplinfo if $tplinfo; $self->load_template($template, $print); # Parse the template. $self->debug("Parsing '$template' with (print => $opt->{print}, compress => $opt->{compress}, strict => $opt->{strict}, escape => $opt->{escape})") if $self->{_debug}; if ($print and $print == 1) { # parse_print return print $self->_parse($template, $opt); } else { # parse or parse_stream return $self->_parse($template, $opt); } } sub parse_print { # --------------------------------------------------------------- # Print output rather than returning it. Faster than parse_stream, # but obviously, it does not stream. # my $self = shift; $self->parse(@_[0 .. 2], 1); } $COMPILE{parse_stream} = __LINE__ . <<'END_OF_SUB'; sub parse_stream { # --------------------------------------------------------------- # Print output as template is parsed. Only use if you really want # streaming. Before using, you should probably set $| = 1, or you # sort of defeat the whole point. # my $self = shift; $self->parse(@_[0 .. 2], 2) } END_OF_SUB $COMPILE{parse_string} = __LINE__ . <<'END_OF_SUB'; sub parse_string { # --------------------------------------------------------------- # Parses a string, only opts allowed is print mode on or off. # Internal use only. # my ($self, $string, $opt) = @_; my $code = $self->_compile_string($string, $opt->{print}); my $return = $code->($self); if ($opt->{print}) { return $opt->{print} == 2 ? $return : print $$return; } else { return $$return; } } END_OF_SUB # Returns the hash ref in the .tplinfo file. Takes a single argument: The # directory in which to look for a .tplinfo file (subdirectory "local" will be # considered first, if it exists). sub load_tplinfo { my $self = shift; my $root = shift; my $tplinfo_file; if (-e "$root/local/.tplinfo") { $tplinfo_file = "$root/local/.tplinfo"; } elsif (-e "$root/.tplinfo") { $tplinfo_file = "$root/.tplinfo"; } if ($tplinfo_file) { local($!,$@); my $tplinfo = do $tplinfo_file; if (!$tplinfo) { $! and return $self->error('TPLINFO_CANT_LOAD', 'FATAL', $tplinfo_file, "$!"); $@ and return $self->error('TPLINFO_CANT_COMPILE', 'FATAL', $tplinfo_file, "$@"); } ref $tplinfo ne 'HASH' and return $self->error('TPLINFO_NOT_HASH', 'FATAL', $tplinfo_file, "$tplinfo"); return $tplinfo; } return; } sub load_template { # --------------------------------------------------------------- # Loads either a given filename, or a template string into the FILE_CACHE. # my ($self, $file, $print) = @_; # If this is a full root (either starts with / or c:, where c is any char) # Then set the root and the filename appropriately. We do this so includes are # relative to the directory that is being parsed. if ((index ($file, '/') == 0) or (index ($file, ':') == 1)) { $self->{root} = substr($file, 0, rindex($file, '/')); substr($file, 0, rindex($file, '/') + 1) = ''; } # Get the full file name. my $full_file = $self->{root} . "/" . $file; my $this_file = $file; my $this_file_type; my $filename = $file; $filename =~ s|/|__|g; my $full_compiled = $self->{root} . "/compiled/" . $filename . ".compiled" . (($print and $print == 2) ? ".print" : ""); # Load from cache if we have it, otherwise load from disk. If it's in cache # make sure the file hasn't changed on disk (comparse size and length). if ($self->{cache} and not $self->{dont_save}) { my $compiled; if (($print and $print == 2) ? (exists $FILE_CACHE_PRINT{$full_file}) : (exists $FILE_CACHE{$full_file})) { $self->debug("'$full_file' exists in the " . (($print and $print == 2) ? "parse_stream" : "parse") . " cache") if $self->{_debug}; $compiled = 1; } elsif (-f $full_compiled and -r _) { local($@, $!); $full_compiled =~ /(.*)/; $full_compiled = $1; if ($print and $print == 2) { local $^W; # Prevent a "subroutine redefined" warning $FILE_CACHE_PRINT{$full_file} = do $full_compiled; $FILE_CACHE_PRINT{$full_file} and ($compiled = 1); } else { local $^W; # Prevent a "subroutine redefined" warning $FILE_CACHE{$full_file} = do $full_compiled; $FILE_CACHE{$full_file} and ($compiled = 1); } if (! $compiled) { $self->debug("Could not compile template '$full_file'. Errors: \$\@: $@, \$!: $!") if $self->{_debug}; } } my ($deps, $date, $version); if ($compiled) { if ($print and $print == 2) { $deps = $FILE_CACHE_PRINT{$full_file}->{deps} || []; $date = $FILE_CACHE_PRINT{$full_file}->{parse_date} || 0; $this_file_type = $FILE_CACHE_PRINT{$full_file}->{file_type} || 'REL'; $version = $FILE_CACHE_PRINT{$full_file}->{parser_version} || 0; } else { $deps = $FILE_CACHE{$full_file}->{deps} || []; $date = $FILE_CACHE{$full_file}->{parse_date} || 0; $this_file_type = $FILE_CACHE{$full_file}->{file_type} || 'REL'; $version = $FILE_CACHE{$full_file}->{parser_version} || 0; } if ($version == $VERSION) { my $reload = 0; DEPENDENCIES: foreach my $fileinfo ("$this_file_type:$this_file", @$deps) { my $file = $fileinfo; # We can't change anything in $deps directly as that would change the cache $file =~ s/^(REL|LOCAL|ABS|INH|MISSING)://; # Relative, local, absolute, or inherited. my $type = $1 || 'ABS'; # Shouldn't ever fall back to 'ABS', but just in case if ($type eq 'MISSING') { # The template couldn't be found; we need to recompile if it has been created exists. my $root = $self->{root}; if (-r "$root/local/$file") { $reload = 1; } elsif (-r "$root/$file") { $reload = 1; } elsif (-r $file) { $reload = 1; } else { # Scan the inheritance tree my $root = $root; # ;-) until ($reload) { # Try going one more level in the inheritance tree my $tplinfo = $self->load_tplinfo($root); if ($tplinfo and my $inherit = $tplinfo->{inheritance}) { if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path $root = $inherit; } else { # Relative inheritance path. This might eventually look like /blah/a/../b/../c/../d/../e - Messy, but it works $root .= "/$inherit"; } } else { last; # We haven't found it, and there isn't any (more) inheritance } # Look for the include in the inherited directory: if (-r "$root/local/$file") { $reload = 1; } elsif (-r "$root/$file") { $reload = 1; } } } if ($reload) { $self->debug("Recompiling '$full_file' because previously missing dependency '$file' now exists") if $self->{_debug}; if ($print and $print == 2) { delete $FILE_CACHE_PRINT{$full_file}; } else { delete $FILE_CACHE{$full_file}; } last; } } if ($type eq 'ABS') { if ((stat($file))[9] > $date) { $self->debug("Recompiling '$full_file' because dependency '$file' has changed") if $self->{_debug}; $reload = 1; if ($print and $print == 2) { delete $FILE_CACHE_PRINT{$full_file}; } else { delete $FILE_CACHE{$full_file}; } last; } } elsif ($type eq 'REL' or $type eq 'LOCAL') { my $bad; if ($type eq 'LOCAL') { $bad = (!-r "$self->{root}/local/$file" or (stat _)[9] > $date); } else { # REL $bad = (-r "$self->{root}/local/$file" or (stat(-r "$self->{root}/local/$file" ? "$self->{root}/local/$file" : "$self->{root}/$file"))[9] > $date); } if ($bad) { if ($self->{_debug}) { if ($type eq 'LOCAL' and not -r _) { $self->debug("Recompiling '$file' because it no longer exists in 'local'"); } elsif ($file eq $this_file) { $self->debug("Recompiling '$file' because it has changed"); } elsif ($type eq 'REL' and -r "$self->{root}/local/$file") { $self->debug("Recompiling '$full_file' because dependency '$file' now exists in 'local'"); } else { $self->debug("Recompiling '$full_file' because dependency '$file' has changed"); } } $reload = 1; if ($print and $print == 2) { delete $FILE_CACHE_PRINT{$full_file}; } else { delete $FILE_CACHE{$full_file}; } last; } } elsif ($type eq 'INH') { my ($f) = $file =~ /^(?:(?:REL|LOCAL|INH):)*(.*?)$/; if (-r "$self->{root}/local/$f" or -r "$self->{root}/$f") { $self->debug("Recompiling '$full_file' because it was inherited or contained inherited includes, but now exists locally") if $self->{_debug}; $reload = 1; ($print and $print == 2) ? delete $FILE_CACHE_PRINT{$full_file} : delete $FILE_CACHE{$full_file}; last; } elsif (not $self->{tplinfo} or not $self->{tplinfo}->{inheritance}) { $self->debug("Recompiling '$full_file' because it was inherited or contained inherited includes, but the .tplinfo file does not exist or does not contain inheritance information") if $self->{_debug}; $reload = 1; ($print and $print == 2) ? delete $FILE_CACHE_PRINT{$full_file} : delete $FILE_CACHE{$full_file}; last; } my $inheritance_depth = 0; my $inherit = $self->{tplinfo}->{inheritance}; my $root = $self->{root}; while ($type eq 'INH') { $inheritance_depth++; if (not $inherit) { $self->debug("Recompiling '$full_file' because it is inherited ($inheritance_depth deep) but no inheritance exists for $inherit.") if $self->{_debug}; $reload = 1; ($print and $print == 2) ? delete $FILE_CACHE_PRINT{$full_file} : delete $FILE_CACHE{$full_file}; last DEPENDENCIES; } if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path $root = $inherit; } else { # Relative inheritance path $root .= "/$inherit"; } $inherit = undef; my $tplinfo = $self->load_tplinfo($root); $inherit = $tplinfo->{inheritance} if $tplinfo and $tplinfo->{inheritance}; $file =~ s/^(REL|LOCAL|INH)://; $type = $1 || 'REL'; next if $type eq 'INH'; my $bad; if ($type eq 'LOCAL') { $bad = (!-r "$root/local/$file" or (stat _)[9] > $date); } else { # REL $bad = (-r "$root/local/$file" or (stat("$root/$file"))[9] > $date); } if ($bad) { if ($self->{_debug}) { if ($type eq 'LOCAL' and not -r _) { $self->debug("Recompiling '$full_file' because '$file' no longer exists in 'local' (inherited, depth: $inheritance_depth)"); } else { $self->debug("Recompiling '$full_file' because dependency '$file' has changed (inherited, depth $inheritance_depth)"); } } $reload = 1; ($print and $print == 2) ? delete $FILE_CACHE_PRINT{$full_file} : delete $FILE_CACHE{$full_file}; last DEPENDENCIES; } } } } unless ($reload) { $self->debug("'$full_file' does not need to be reloaded. Using cached version.") if $self->{_debug}; return 1; # It doesn't need to be reloaded. } } } elsif ($self->{_debug}) { $self->debug("Compiling '$full_file' (compiled version does not exist or has an incorrect version)") if ($self->{_debug}); } } if ($self->{dont_save}) { require GT::Template::Parser; my $parser = GT::Template::Parser->new(indent => $self->{indent}, begin => $self->{begin}, end => $self->{end}); $parser->debug_level($self->{_debug}) if $self->{_debug}; my ($eval) = $parser->parse( $this_file, { root => $self->{root} }, ($print and $print == 2) ); my $code; { # Treat this like a string compilation local ($@, $^W); eval "sub GT::Template::parsed_template { $$eval }"; $code = \>::Template::parsed_template unless $@; } if (ref $code ne 'CODE') { return $self->error('CANTRUNSTRING', 'FATAL', $$eval, "$@"); } if ($print and $print == 2) { $FILE_CACHE_PRINT{$full_file} = { code => $code, dont_save => 1 }; } else { $FILE_CACHE{$full_file} = { code => $code, dont_save => 1 }; } } else { # Needs to be reparsed for some reason (not in cache, old, etc.) so load it. if (not -e $self->{root} . "/compiled") { mkdir($self->{root} . "/compiled", 0777) or return $self->error('CANTDIR', 'FATAL', "$self->{root}/compiled", "$!"); chmod 0777, $self->{root} . "/compiled"; } elsif (not -d _) { $self->error('NOTDIR', 'FATAL', $self->{root} . "/compiled"); } elsif (not -w _) { $self->error('DIRNOTWRITEABLE', 'FATAL', "$self->{root}/compiled"); } $self->_compile_template($this_file, $full_compiled, $print); local($@, $!); local $^W; # Prevent a "subroutine redefined" warning my $data = do $full_compiled or return $self->error(CANTRUN => FATAL => $full_compiled, "\$\@: $@. \$!: $!"); if ($print and $print == 2) { $FILE_CACHE_PRINT{$full_file} = $data } else { $FILE_CACHE{$full_file} = $data } } return 1; } sub vars { # --------------------------------------------------------------- # Retuns a hash ref of the current tags the template parser will # use during parsing. # return $_[0]->{VARS}; } sub load_alias { # --------------------------------------------------------------- # Sets what aliases will be available in the template, can take a hesh, # hash ref or a GT::Config object. # my $self = shift; my $p; $self->{ALIAS} ||= {}; ref $_[0] ? ($p = shift) : ($p = {@_}); while ($p) { if (ref $p eq 'HASH' or UNIVERSAL::isa($p, 'GT::Config')) { # A GT::Config module (or subclass) is a tied hash. foreach (keys %$p) { $self->{ALIAS}->{$_} = $p->{$_}; } } $p = shift; } } sub load_vars { # --------------------------------------------------------------- # Sets what variables will be available in the template, can take a hash, # hash ref, cgi object, or a GT::Config object. # my $self = shift; my $p; $self->{VARS} ||= {}; ref $_[0] ? ($p = shift) : ($p = {@_}); while ($p) { if (ref $p eq 'HASH' or UNIVERSAL::isa($p, 'GT::Config')) { # A GT::Config module (or subclass) is a tied hash. foreach (keys %$p) { $self->{VARS}->{$_} = $p->{$_}; } } elsif ((ref $p eq 'GT::CGI') or (ref $p eq 'CGI')) { foreach ($p->param) { $self->{VARS}->{$_} = $p->param($_); } } $p = shift; } } sub clear_vars { # --------------------------------------------------------------- # Clears the namespace. # $_[0]->{VARS} = {}; $_[0]->debug ("Clearing internal variables.") if ($_[0]->{_debug}); } sub tags { # --------------------------------------------------------------- # This should only be called from functions that are called. $VARS is a # localized global consisting of the current parser's $self->{VARS}. # return $VARS } $COMPILE{dump} = __LINE__ . <<'END_OF_SUB'; sub dump { # --------------------------------------------------------------- # Dumps the variables, used as a tag <%GT::Dumper::dump%> to display # all tags available on the template. # my %opts = @_; my $tags = GT::Template->tags; require GT::Dumper; my $output = ''; if ($opts{'-text'}) { $output = "Available Variables\n"; foreach my $key (sort keys %$tags) { my $val = $tags->{$key}; $val = $$val if ref $val eq 'SCALAR'; $val = GT::Dumper::Dumper($val) if ref $val; local $^W; $output .= "$key => $val\n"; } } else { my $font = 'font face="Tahoma,Arial,Helvetica" size="2"'; $output = qq~~; foreach my $key (sort keys %$tags) { my $val = $tags->{$key}; $val = $$val if ref $val eq 'SCALAR'; $val = GT::Dumper::Dumper($val) if ref $val; $val = GT::CGI::html_escape($val); local $^W; $val =~ s/\n/
\n/g; $val =~ s/ / /g; $output .= qq~~; } $output .= qq~
<$font>Available Variables
<$font>$key$val
~; } return \$output; } END_OF_SUB sub _parse { # --------------------------------------------------------------- # Sets the parsing options, and gets the code ref and runs it. # my ($self, $template, $opt) = @_; my $compress = exists $opt->{compress} ? $opt->{compress} : $self->{compress}; local $self->{opt} = {}; $self->{opt}->{strict} = exists $opt->{strict} ? $opt->{strict} : $self->{strict}; $self->{opt}->{print} = exists $opt->{print} ? $opt->{print} : $self->{print}; $self->{opt}->{escape} = exists $opt->{escape} ? $opt->{escape} : $self->{escape}; $self->{opt}->{package} = exists $opt->{package} ? $opt->{package} : caller(1) || 'main'; $self->{opt}->{func_code} = exists $opt->{func_code} ? $opt->{func_code} : $self->{func_code}; $self->{opt}->{heap} = exists $opt->{heap} ? $opt->{heap} : $self->{heap}; # Set the root if this is a full path so includes can be relative to template. if ((index ($template, '/') == 0) or (index ($template, ':') == 1)) { $self->{root} = substr($template, 0, rindex($template, '/')); substr($template, 0, rindex($template, '/') + 1) = ''; } my $root = $self->{root}; my $full_file = $self->{root} . '/' . $template; my ($code, $dont_save); if ($self->{opt}->{print} == 2) { $code = $FILE_CACHE_PRINT{$full_file}->{code}; $dont_save = $FILE_CACHE_PRINT{$full_file}->{dont_save}; } else { $code = $FILE_CACHE{$full_file}->{code}; $dont_save = $FILE_CACHE{$full_file}->{dont_save}; } my $output = $code->($self); return $output if $self->{opt}->{print} == 2; # Compress output if requested. if ($compress) { $self->debug("Compressing output for template '$template'.") if ($self->{_debug}); my $pre_size = length $$output if $self->{_debug}; $self->_compress($output); my $post_size = length $$output if $self->{_debug}; $self->debug(sprintf "Output size before/after compression: %d/%d. That's a reduction of %.1f%%.", $pre_size, $post_size, (1 - $post_size / $pre_size)) if $self->{_debug}; } return $$output; } $COMPILE{_compile_template} = __LINE__ . <<'END_OF_SUB'; sub _compile_template { # ------------------------------------------------------------------- # Loads the template parser and compiles the template and saves it # to disk. # my ($self, $file, $full_compiled, $print) = @_; $self->debug("Compiling template $file (into $full_compiled)") if $self->{_debug}; require GT::Template::Parser; my $parser = GT::Template::Parser->new(indent => $self->{indent}, begin => $self->{begin}, end => $self->{end}); $parser->debug_level($self->{_debug}) if $self->{_debug}; my ($code, $deps, $file_type) = $parser->parse( $file, { root => $self->{root} }, ($print and $print == 2) ); local *FH; open FH, "> $full_compiled" or return $self->error('CANTOPEN', 'FATAL', $full_compiled, "$!"); my $localtime = localtime; my $time = time; my $dep_string = '[' . join(',', map qq|"\Q$_\E"|, @$deps) . ']'; (my $escaped = $full_compiled) =~ s/(\W)/sprintf "_%x", ord($1)/ge; print FH qq |# This file is a compiled version of a template that can be run much faster # than reparsing the file, yet accomplishes the same thing. You should not # attempt to modify this file as any changes you make would be lost as soon as # the original template file is modified. # Generated: $localtime # Editor: vim:syn=perl local \$^W; { parse_date => $time, deps => $dep_string, parser_version => $VERSION, file_type => '$file_type', code => \\>::Template::parsed_template }; sub GT::Template::parsed_template { $$code }|; close FH; chmod 0666, $full_compiled; return; } END_OF_SUB $COMPILE{_compile_string} = __LINE__ . <<'END_OF_SUB'; sub _compile_string { # ----------------------------------------------------------------- # Like _compile_template, except that this returns a code reference # for the passed in string. # Takes two arguments: The string, and print mode. If print mode is # on, the code will print everything and return 1, otherwise the # return will be the result of the template string. my ($self, $string, $print) = @_; $self->debug("Compiling string '$string' in " . (($print and $print == 2) ? "stream mode" : "return mode")) if $self->{_debug}; if (!$string) { $self->debug("Actual parsing skipped for empty or false string '$string'") if $self->{_debug}; if ($print and $print == 2) { return sub { print $string }; } else { return sub { \$string }; } } require GT::Template::Parser; my $parser = GT::Template::Parser->new(indent => $self->{indent}, begin => $self->{begin}, end => $self->{end}); $parser->debug_level($self->{_debug}) if $self->{_debug}; my ($eval) = $parser->parse( $string, { root => $self->{root}, string => $string }, ($print and $print == 2) ); local ($@, $^W); eval "sub GT::Template::parsed_template { $$eval }"; my $code; $code = \>::Template::parsed_template unless $@; unless (ref $code eq 'CODE') { return $self->error('CANTRUNSTRING', 'FATAL', "sub GT::Template::parsed_template { $$eval }", "$@"); } return $code; } END_OF_SUB $COMPILE{_call_func} = __LINE__ . <<'END_OF_SUB'; sub _call_func { # --------------------------------------------------------------- # Calls a function. The arguments are set in GT::Template::Parser. # If the function returns a hash, it is added to $self->{VARS}. # The result of the function is escaped, if escape mode is turned # on. # my ($self, $torun, @args) = @_; if (exists $self->{ALIAS}->{$torun}) { $torun = $self->{ALIAS}->{$torun}; } no strict 'refs'; my $rindex = rindex($torun, '::'); my $package = substr($torun, 0, $rindex) if $rindex != -1; my ($code, $ret); my @err = (); my $ok = 0; if ($package) { my $func = substr($torun, rindex($torun, '::') + 2); (my $pkg = $package) =~ s,::,/,g; until ($ok) { local ($@, $SIG{__DIE__}); eval { require "$pkg.pm" }; if ($@) { push @err, $@; } elsif (defined(&{$package . '::' . $func}) or defined &{$package . '::AUTOLOAD'} and defined %{$package . '::COMPILE'} and exists ${$package . '::COMPILE'}{$func} ) { $ok = 1; $code = \&{$package . '::' . $func}; last; } else { push @err, sprintf($ERRORS->{NOSUB}, "$package\::$func", "$pkg.pm"); } my $pos = rindex($pkg, '/'); $pos == -1 ? last : (substr($pkg, $pos) = ""); } } elsif (ref $self->{VARS}->{$torun} eq 'CODE') { $code = $self->{VARS}->{$torun}; $ok = 1; } if ($ok) { local $VARS = $self->{VARS}; if ($self->{opt}->{heap}) { push @args, $self->{opt}->{heap} } if ($package and ref($self->{opt}->{func_code}) eq 'CODE') { $ret = $self->{opt}->{func_code}->($torun, @args); } else { $ret = $code->(@args); } if (ref $ret eq 'HASH') { for (keys %$ret) { $self->{VARS}->{$_} = $ret->{$_}; } $ret = ''; } } elsif ($package) { $ret = $self->{opt}->{strict} ? \sprintf($ERRORS->{CANTLOAD}, $package, join(",
\n", @err)) : ''; } else { $ret = $self->{opt}->{strict} ? \sprintf($ERRORS->{NOTCODEREF}, $torun) : ''; } $ret = '' if not defined $ret; $ret = ref $ret eq 'SCALAR' ? $$ret : $self->{opt}->{escape} ? GT::CGI::html_escape($ret) : $ret; return $ret; } END_OF_SUB $COMPILE{_compress} = __LINE__ . <<'END_OF_SUB'; sub _compress { # -------------------------------------------------------- # Compress html by removing extra space (idea/some re from HTML::Clean). # Avoids compressing pre tags. # my ($self, $text) = @_; if ($$text =~ /<(?:pre|textarea)/i) { $$text .= "
";
        $$text =~ s(\G(.*?)(<(?:pre|textarea).*?))(
                    my $html  = $1;
                    my $pre   = $2 || '';
                    $html =~ s,[\r\n]+,\n,sg;
                    $html =~ s,\s+\n,\n,sg;
                    $html =~ s,\n\s+<,\n<,sg;
                    $html =~ s,\n\s+,\n ,sg;
                    $html =~ s,>\n\s*<,> <,sg;
                    $html =~ s,\s+>,>,sg;
                    $html =~ s,<\s+,<,sg;
                    $html . $pre;
                )iesg;
        substr($$text, -11) = '';
    }
    else {
        $$text =~ s,[\r\n]+,\n,sg;
        $$text =~ s,\s+\n,\n,sg;
        $$text =~ s,\n\s+<,\n<,sg;
        $$text =~ s,\n\s+,\n ,sg;
        $$text =~ s,>\n\s*<,> <,sg;
        $$text =~ s,\s+>,>,sg;
        $$text =~ s,<\s+,<,sg;
    }
    return $text;
}
END_OF_SUB

sub _get_var {
# ---------------------------------------------------------------
# Basically a softer version of _get_value that returns the string
# value of _get_value - so if it's a hash, it adds the variables
# to the current tags, and returns undef.
# It takes 3 args - the "thing" to check, escape, and strict.
# If this returns undef, nothing is printed.
#
    my ($self, $str, $escape, $strict) = @_;
    my ($ret, $good) = ('', 1);

    if (ref($str) eq 'HASH') {
        $ret = $str;
    }
    elsif (exists $self->{VARS}->{$str}) {
        if (ref $self->{VARS}->{$str} eq 'CODE') {
            if ($self->{opt}->{heap}) {
                $ret = $self->{VARS}->{$str}->($self->{VARS}, $self->{opt}->{heap});
            }
            else {
                $ret = $self->{VARS}->{$str}->($self->{VARS});
            }
            $ret = '' if not defined $ret;
        }
        else {
            $ret = $self->{VARS}->{$str};
            $ret = '' if not defined $ret;
        }
    }
    elsif (exists $self->{ALIAS}->{$str}) {
        $ret = $self->_call_func($self->{ALIAS}->{$str});
    }
    else {
        $good = 0;
    }

    if (not $good) {
        return $strict ? sprintf($ERRORS->{UNKNOWNTAG}, $str) : undef;
    }
    if (ref $ret eq 'HASH') {
        for (keys %$ret) {
            $self->{VARS}->{$_} = $ret->{$_};
        }
        return;
    }
    return if not defined $ret;
    return $$ret if ref $ret eq 'SCALAR';
    return $ret if not $escape;
    $ret =~ s/&/&/g;
    $ret =~ s//>/g;
    $ret =~ s/"/"/g;
    return $ret;
}


sub _get_value {
# ---------------------------------------------------------------
# Takes a key, and returns the value, in scalar context.
# In list context it returns a two-item list: the value is first,
#   then a 1 or undef to indicate the validity of the tag.
#
    my ($self, $str, $strict) = @_;
    my $ret = '';
    local $self->{opt}->{strict} = $strict;
    if (ref($str) eq 'HASH') {
        $str;
    }
    elsif (exists $self->{VARS}->{$str}) {
        if (ref $self->{VARS}->{$str} eq 'CODE') {
            my $ret;
            if ($self->{opt}->{heap}) {
                $ret = $self->{VARS}->{$str}->($self->{VARS}, $self->{opt}->{heap});
            }
            else {
                $ret = $self->{VARS}->{$str}->($self->{VARS});
            }
            $ret = '' if not defined $ret;
            return wantarray ? ($ret, 1) : $ret;
        }
        else {
            my $ret = $self->{VARS}->{$str};
            $ret    = '' if not defined $ret;
            return wantarray ? ($ret, 1) : $ret;
        }
    }
    else {
        $ret = $strict ? \sprintf($ERRORS->{UNKNOWNTAG}, $str) : '';
        return wantarray ? ($ret, undef) : $ret;
    }
}

1;

__END__

=head1 NAME

GT::Template - simple template parsing module

=head1 SYNOPSIS

    use GT::Template;
    my $var = GT::Template->parse('file.txt', { key => 'value' });
    ...
    print $var;

or

    use GT::Template;
    GT::Template->parse_print('file.txt', { key => 'value' });

=head1 DESCRIPTION

GT::Template provides a simple way (one line) to parse a template (which
can be either a file or a string) and make sophisticated replacements.

It supports simple replacements, conditionals, function calls, includes
and more.

=head2 Template Syntax

The template parser replaces tags with content. By default a tag is
anything enclosed between <% and %>. These can be changed by specifying
the $tpl->begin and $tpl->end methods.

=over 4

=item Variable Substitution

At the simplest level of GT::Template are simple variable replacements such as:

    You are <%age%> years old.

where age would get replaced with a value.

=item Sets

You can set values from within a template by using:

    <%set Title = 'Login'%>

and now <%Title%> will be equal to Login. This is especially useful for includes.
If you have a header.htm that gets included, you can do:

    <%set Title = 'Login'%>
    <%include header.htm%>

and then in your header.htm:
    
    
        
            <%Title%>
            
        
    
    
So that you can have different titles, but always the same header file.

You can also set one variable to the value of another, such as:

    <%set title = $return_title%>

This will set the variable "title" with the value of the variable "return_title."

=item Operators

GT::Template is capable of performing some basic math calculations and one
string-multiple function in templates displaying the results in the parsed template.

For example, if the 'age' variable is 15, the following tag:

    <%age + 10%>

will display 25 in the template. Besides addition there are the following
operators, which work as expected:
    -
    *
    /
    % (remainder)
    ^ (raised to the power of)

The following operators are also worth explaining:
    
    i/
    /N
    ~ (Remainder difference)
    x (String multiplier)

i/ performs integral division between the two numbers. For example,
'4' i/ 3 will result in 1. '100' i/ 3 would result in 33, etc.

/N does not actually use a literal N, instead N should be replaced
by a number. The result will be formatted (and rounded) to N decimal
places. For example, '4' /3 3 would result in: 1.333, while '5' /3 3
would give you: 1.667. '3' /3 3 would be 1.000.

Note that i/ and /0 are not the same, as can be illustrated here:
38 i/ '3.8' => 12 - becomes 38 i/ 3
38 /0 '3.8' => 10 - 38 / 3.8 is calculated, then rounded with 0 decimal place
precision.

You should be sure of which one you mean to use, or you may end up with
unexpected results.

~ is used to get a remainder difference. Where 8 % 5 would return 3, 8 ~ 5 will
return 2.  This is calculated as the divisor (5) minus the remainder (3). This
is useful when generating tables in a loop - when you hit the end of the loop,
you want to be able to put an empty cell with a colspan of however many rows
are left. Something like: <%row_num % 5%> will give you the proper value.

As mentioned, there is also one string operator, 'x'. When you use 'x', the
variable (or value as we'll see in a second) will be displayed "n" times, where
"n" is the integral value of the right hand side.

Assuming that the 'name' variable is 'Jason', this tag:

    <%name x 2%>

will display JasonJason in the parsed template. Like this, it isn't all that useful
because you could simply put <%name%><%name%> in your template. However, the
right hand side may instead use the value of a variable, such as in this example:

    <%name x $print%>

Assuming that 'name' is still 'Jason', and that 'print' is 3, this would display:

    JasonJasonJason

Though this is useful as is, this is taken a step furthur: the first does not
always have to be a variable. By using 'single quotation marks' or "double
quotation marks" we can display fixed text a variable number of times.

For example:

    <%'My Text' x $print%>

Again assuming that the variable 'print' is 3, this will print:
    
    My TextMy TextMy Text

this comes in handy when doing things like indentation.

Note that what we want to use for "My Text" might contain " or ' characters. If
it only contains ", and not ', it is advisible to use ' instead of " as the
string delimiter. If, however, you need to use the same quotes inside the string
as you use to delimit the string, you should precede the quotes with a blackslash
(\) and any backslashes with a backslash. For example, if you wanted to display
the three characters \'" thirty times, you would have to write it as one of the
following two lines:

    <%"\\'\"" x 30%>
    <%'\\\'"' x 30%>

Hopefully such occurances are rare, but not impossible; hence the support for
using either ' or " as the delimiting character.

=item Set + Operators

You can add, subtract, etc. to your variables with the following syntax:

    <%set variable += 3%>

+= can be changed to the following:

    += - Adds to a variable
    -= - Subtracts from a variable
    *= - Multiplies a variable
    /= - Divides a variable
    %= - Set a variable to a remainder
    x= - Multiplies a string
    ^= - Raise a variable to a power

=item Conditionals

You can use conditionals if, ifnot (or unless), elseif, and else as in:

    <%if age%>
        You are <%age%> years old.
    <%elseif sex%>
        You are <%sex%>.
    <%else%>
        I know nothing about you!
    <%endif%>


    <%ifnot login%>
        You are not logged in!
    <%endif%>


    <%unless age%>
        I don't know how old you are!
    <%endif%>

If you like you may use 'elsif' instead of 'elseif' (drop the 'e').

All conditionals must be ended with an "endif" tag, although may contain elseif
or else conditionals between the "if" and "endif" tags.

Nested conditionals are fully supported:

    <%if age%>
        You are <%age%> years old
        <%if sex%>
            and you are <%sex%>
        <%endif%>
    <%endif%>

=item Comparison

Inside conditionals you can use <, >, <=, >=, ==, !=, lt, gt, le, ge, eq, ne, and like. So you can do:

    <%if age == 15%>
        You're 15!
    <%endif%>

where the == can be replaced with any operator listed above. If the right hand
side of the equation starts with a '$', the string will be interpolated as
a variable. You can avoid this by using quotes around the right hand value.
The left hand side must always be a variable. lt, gt, le, ge, eq, and ne are the
alphabetical equivelants of <, >, <=, >=, ==, and !=, respectively. 'like' will
be true if the variable contains the right hand side.

=item Boolean

If statements (as well as elseif statements) may contain multiple conditions using
one of the two booleans: 'or' or 'and'. For example:

    <%if age and sex and color%>
        I know your age, sex and hair color.
    <%else%>
        I don't have enough information about you!
    <%endif%>

    <%if age < 10 or age > 90 or status eq banned%>
        You are not permitted to view this page.
    <%endif%>

It should be noted that it is not possible to mix both 'or' and 'and' in one
complex if statement - you may, however, use the same boolean multiple times in
one statement. (Brackets) are also not supported.

Internally, loops will be short-circuited as soon as possible. That means that
for the following tag:
    <%if foo = 1 or foo = 2 or foo = 3%>
the following will occur:
First, variable "foo" will be tested to see if it is numerically equal to 1. If
it is, the rest of the checks are aborted since the if will pass regardless. If
it is not, foo = 2 will be checked, and if true, will abort the next check, and
so on until a condition is true or the end of the list of statements is encountered.

Likewise with and, except with and the parser will stop checking as soon as the
first false value is encountered (since a false value means the entire condition
will be false).

=item Loops

Inside your template you can use loops to loop through an array reference,
or code reference. If using an array reference, each element should be a
hash reference, and when using a code reference every return should be a
hash reference - or undef to end the loop. The variables in the hash
reference will then be available for that iteration of the loop.

For example:

    <%loop people%>
        <%if name eq 'Jason'%>
            I have <%color%> hair.
        <%else%>
            <%name%> has <%color%> hair.
        <%endif%>
    <%endloop%>

would loop through all values of pens, and for each one would print the
sentence substituting the color of the pen. Also, inside your loop you can
use the following tags:

    <%row_num%> - a counter for what row is being looped, starts at 1.
    <%first%>   - boolean that is true if this is the first row, false otherwise.
    <%last%>    - boolean that is true if this is the last row, false otherwise.
    <%inner%>   - boolean that is true if this is not first and not last.
    <%even%>    - boolean is true if row_num is even.
    <%odd%>     - boolean is true if row_num is odd.

You could use even and odd tags to produce alternating colors like:

    <%loop results%>
        ..
    <%endloop%>

Also, you can use <%lastloop%> to abort the loop and skip straight to the
current loop's <%endloop%> tag, and <%nextloop%> to load the next loop variables
and jump back to the beginning of the current loop.

The 6 built-in variables (row_num, first, last, ...) and any variables set
via the loop variable will only be available for the current loop iteration,
after which the variables of the next loop iteration will be set, or, for
variables that exist in one iteration but not the next, the variables that
existed prior to the loop being called will be restored.

=item escape_url escapeURL

Most variable will already be escaped for html viewing by default. Being
able to use these variables on one page in a URL and in the html page
can be a bit tricky. If you are using escape mode, this function simply
URL encodes the variable. Otherwise, this function unescapes html escapes
and URL encodes the variable.

    <%escape_url somevar%>

=item escape_html escapeHTML

Whether or not in escape mode, this directive will HTML escape the variable.
The variable will _not_ be escaped twice in escape mode.

    <%escape_html somevar%>

=item unescape_html unescapeHTML

The directive will unescape the HTML escapes &, <, >, and "

=item escape_js escapeJS

This directive will safely escape a javascript variable so that it can be
used inside a javascript string delimited with either "double quotes" or
'single quotes.'

    <%escape_js somevar%>

=item nbsp

This directive will display the tag with all whitespace in a variable
converted to non-breaking spaces ( ). This is useful when attempting
to display something accurately which may contain spaces, or when attempting
to ensure that a value does not wrap over multiple lines.

=item Includes

You can include other files. Any tags inside the includes will be evaluated.
You can also have includes inside of includes, inside if statements, or even
inside loops. The following tag:

    <%if info%>
        <%include info.txt%>
    <%else%>
        <%include noinfo.txt%>
    <%endif%>

will include either the file info.txt (if info is true) or noinfo.txt (if info
is false or not set). It must be in the template's root directory which is defined
using $obj->root, or '.' by default.

A useful application of the include tag is to include files inside a loop, as in:

    <%loop people%>
        <%include person.txt%>
    <%endloop%>

=item Functions

You can call functions in either the variable substitution or in
the comparison. The function must reside in a package, and you
must do the full qualification.

    A script header normally looks like <%CGI::header%>

which would call &CGI::header(). You can pass arguments to this as in:

    A script header normally looks like <%CGI::header ('text/html')%>.

Also, you can pass any currently available template variable to the function
using:

    <%CGI::header ($variable)%>

Multiple arguments may be passed by comma separating the arguments, as in:
    <%Mypackage::mysub($age, 'Title')%>

If a function returns a hash reference, those values will be added to the
current substitution set. Suppose you have a function:

    package Mypackage;
    sub load_globals {
        ..
        return { age => 15, color => red };
    }

You could then do:

    <%Mypackage::load_globals%>
    You are <%age%> years old, with <%color%> hair!

Functions are loaded while parsing, so calling the function with different
arguments (to set your variables to different values) is possible.

Since package names can make functions rather long and ugly, you can call
-Eparse() with an "alias" key in the options hash. This key should contain
shortcut => function pairs. For example, if you want to call Foo::Bar::blah() in
your template, you could pass: asdf => 'Foo::Bar::blah', and when <%asdf%> or
<%asdf(...)%> is encountered, Foo::Bar::blah will be called.

=item Booleans with Functions

You can combine boolean if statements with functions, as in:

    <%if age == My::years_old%>
        You are the same age as me!
    <%endif%>

which would call My::years_old() and compare the return value to the value of
the "age" variable. Functions can also be called inside elsif statements.

=item Sets with Functions

Since it is often useful to combine the features of Set and Function calls, 
there is a combination form that can be used. The following code will set a
variable named "age" to the return value of Mypackage::age():

    <%set age = Mypackage::age%>

Arguments passed are the same as the arguments to a regular function.

=back

=head2 Parse Options

The third argument to parse is an optional hash of options. Valid
options include:

=over 4

=item root => path

This sets the path to where the template files are.

=item string => $template

Passing in string => $template will use $template as your template
to parse, rather then load from a file.

=item print => 0

If set to 1, this will print the template to the currently selected
filehandle (STDOUT), and returns 1. If set to 0 (default), returns
parsed tempalte.

=item compress => 0

Setting compress => 1 will compress all white space generated
by the program. This is great for HTML, but shouldn't be used
for text templates.

=item strict => 0

If set to 0, any template errors will not be displayed. The default
is 1. This means if you have a tag <%mytag%> and mytag is not in your
list of variables, with strict on, it will get replaced with an
Unknown tag error, with strict off it will get replaced with an
empty string.

=item escape => 0

This will HTML escape all variables before they are printed. Scalar
references will be dereferenced and B escaped.

=back

The forth option to parse is an optional hash of aliases to set up
for functions. The key should be the function call to alias and the
value should be the function aliased. For example:

    print GT::Template->parse(
        'file.htm',
        { key => 'value' },
        { compress => 1 },
        { myfunc => 'Long::Package::Name::To::myfunc' }
    );

Now in your template you can do:

    <%myfunc('argument')%>

Which will call C.

=head1 EXAMPLES

Some examples to get you going:

    # Parse a string in $template and replace <%key%> with 'value'.
    print GT::Template->parse('stringname', { key => 'value' }, { string => $template });

    # Compress output of template, print it as it is parsed, not after entirely parsed.
    GT::Template->parse_print('file.txt', { key => 'value' }, { compress => 1 });

    # Don't display warnings on invalid keys.
    print GT::Template->parse('file.txt', { key => 'value' }, { strict => 0 });

    # Create a template object using custom settings.
    my $obj = new GT::Template({
                                    root => '/path/to/templates',
                                    compress => 0,
                                    strict => 0,
                                    begin => ' '!>'
                                });
    my $replace = {
                        a => 'b',
                        c => 'd',
                        e => 'f'
                   };

    $obj->parse_print('file2.txt', $replace);

=head1 COPYRIGHT

Copyright (c) 2000 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Template.pm,v 2.78 2002/05/25 06:47:32 jagerman Exp $

=cut
private/lib/GT/Template/0040755000076400010020000000000007477023142013675 5ustar  alexcvsprivate/lib/GT/Template/Editor.pm0100644000076400010020000003022007416167017015456 0ustar  alexcvs# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Template::Editor
#   Author: Alex Krohn
#   $Id: Editor.pm,v 2.4 2002/01/07 00:38:39 alex Exp $
#
# Copyright (c) 2001 Gossamer Threads Inc.  All Rights Reserved.
# ====================================================================
#
# Description:
#   A module for editing templates via an HTML browser.
#

package GT::Template::Editor;
# ===============================================================
    use strict;
    use GT::Base;
    use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS);
    @ISA     = qw/GT::Base/;
    $VERSION = sprintf "%d.%03d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/;
    $DEBUG   = 0;
    $ATTRIBS = { cgi => undef, root => undef, backup => undef, default_dir => '', default_file => '', date_format => '' };
    $ERRORS  = {
        CANTOVERWRITE       => "Unable to overwrite file: %s (Permission Denied). Please set permissions properly and save again.",
        CANTCREATE          => "Unable to create new files in directory %s. Please set permissions properly and save again.",
        CANTMOVE            => "Unable to move file: %s to %s. Reason: %s",
        CANTMOVE            => "Unable to copy file: %s to %s. Reason: %s",
        FILECOPY            => "File::Copy is required in order to make backups.",
    };

sub process {
# ------------------------------------------------------------------
# Loads the template editor.
#
    my $self = shift;

    my $selected_dir  = $self->{cgi}->param('tpl_dir')  || $self->{default_dir} || 'default';
    my $selected_file = $self->{cgi}->param('tpl_file') || '';
    my $tpl_text      = '';
    my $error_msg     = '';
    my $success_msg   = '';
    my ($local, $restore) = (0, 0);

# Create the local directory if it doesn't exist.
    my $tpl_dir   = $self->{root} . '/' . $selected_dir;
    my $local_dir = $tpl_dir . "/local";
    if (! -d $local_dir) {
        mkdir ($local_dir, 0777) or return $self->error ('MKDIR', 'FATAL', $local_dir, "$!");
        chmod (0777, $local_dir);
    }
    my $dir = $local_dir;

# Perform a save if requested.
    if ($self->{cgi}->param('saveas') and my $file = $self->{cgi}->param('tpl_name')) {
        $tpl_text = $self->{cgi}->param('tpl_text'); 
        if (-e "$dir/$file" and ! -w _) {
            $error_msg = sprintf($ERRORS->{CANTOVERWRITE}, $file);
        }
        elsif (! -e _ and ! -w $dir) {
            $error_msg = sprintf($ERRORS->{CANTCREATE}, $dir); 
        }
        else {
            if ($self->{backup} and -e "$dir/$file") {
                $self->copy ("$dir/$file", "$dir/$file.bak")
            }
            local *FILE;
            open (FILE, "> $dir/$file") or return $self->error ('CANTOPEN', 'FATAL', "$dir/$file", "$!");
            $tpl_text =~ s/\r\n/\n/g;
            print FILE $tpl_text;
            close FILE;
            chmod 0666, "$dir/$file";
            $success_msg   = "File has been successfully saved.";
            $local         = 1;
            $restore       = 1 if -e "$self->{root}/$selected_dir/$file";
            $selected_file = $file;
            $tpl_text      = '';
        }
    }
# Delete a local template (thereby restoring the system template)
    elsif (my $restore = $self->{cgi}->param("restore")) {
        if ($self->{backup}) {
            if ($self->move("$dir/$restore", "$dir/$restore.bak")) {
                $success_msg = "System template '$restore' restored";
            }
            else {
                $error_msg = "Unable to restore system template '$restore': Cannot move '$dir/$restore': $!";
            }
        }
        else {
            if (unlink "$dir/$restore") {
                $success_msg = "System template '$restore' restored";
            }
            else {
                $error_msg = "Unable to remove $dir/$restore: $!";
            }
        }
    }
# Delete a local template (This is like restore, but happens when there is no system template)
    elsif (my $delete = $self->{cgi}->param("delete")) {        
        if ($self->{backup}) {
            if ($self->move("$dir/$delete", "$dir/$delete.bak")) {
                $success_msg = "Template '$delete' deleted";
            }
            else {
                $error_msg = "Unable to delete template '$delete': Cannot move '$dir/$delete': $!";
            }
        }
        else {
            if (unlink "$dir/$delete") {
                $success_msg = "Template '$delete' deleted";
            }
            else {
                $error_msg = "Unable to remove $dir/$delete: $!";
            }
        }
    }

# Load any selected template file.  
    if ($selected_file and ! $tpl_text) {
        if (-f "$dir/$selected_file") {
            local (*FILE, $/);
            open FILE, "$dir/$selected_file" or die "Unable to open file $dir/$selected_file: $!";
            $tpl_text = ;
            close FILE;
            $local = 1;
            $restore = 1 if -e "$self->{root}/$selected_dir/$selected_file";
        }
        elsif (-f "$self->{root}/$selected_dir/$selected_file") {
            local (*FILE, $/);
            open FILE, "$self->{root}/$selected_dir/$selected_file" or die "Unable to open file $self->{root}/$selected_dir/$selected_file: $!";
            $tpl_text = ;
            close FILE;
        }
        else {
            $selected_file = '';
        }
    }

# Load a README if it exists.
    my $readme;
    if (-e "$dir/README") {
        local (*FILE, $/);
        open FILE, "$dir/README" or die "unable to open readme: $dir/README ($!)";
        $readme = ;
        close FILE;
    }

# Set the textarea width and height.
    my $editor_rows = $self->{cgi}->param('cookie-editor_rows') || $self->{cgi}->cookie('editor_rows') || 15;
    my $editor_cols = $self->{cgi}->param('cookie-editor_cols') || $self->{cgi}->cookie('editor_cols') || 55;
    my $file_select = $self->template_file_select;
    my $dir_select  = $self->template_dir_select;
    $tpl_text = $self->{cgi}->html_escape($tpl_text);
    my $stats       = $selected_file ? $self->template_file_stats ($selected_file) : {};
    return {
        tpl_name    => $selected_file,
        tpl_file    => $selected_file,
        local       => $local,
        restore     => $restore,
        tpl_text    => \$tpl_text,
        error_message    => $error_msg,
        success_message  => $success_msg,
        tpl_dir     => $selected_dir,
        readme      => $readme,
        editor_rows => $editor_rows,
        editor_cols => $editor_cols,
        dir_select  => $dir_select,
        file_select => $file_select,
        %$stats
    };
}

sub template_file_select {
# ------------------------------------------------------------------
# Returns a select list of templates in a given dir.
#
    my $self = shift;
    my $path = $self->{root};
    my ($dir, $file, %files);
    my $selected_dir   = $self->{cgi}->param('tpl_dir')  || $self->{default_dir} || 'default';
    my $selected_file  = $self->{cgi}->param('tpl_file')  || $self->{default_file} || 'default';

    my $system_dir = $path . "/" . $selected_dir;
    my $local_dir  = $path . "/" . $selected_dir . '/local';
    foreach my $dir ($system_dir, $local_dir) {
        opendir (TPL, $dir) or next;
        while (defined ($file = readdir(TPL))) {
            next if ($file =~ /^\.\.?$/);
            next if ($file eq 'README');
            next if ($file eq 'languages.txt');
            next if ($file eq 'globals.txt');
            next if ($file =~ /\.bak/);
            next unless (-r "$dir/$file" and ! -d _);
            $files{$file} = 1;
        }
        closedir (TPL);
    }
    my $f_select_list = "";

    return $f_select_list;
}

sub template_dir_select {
# ------------------------------------------------------------------
# Returns a select list of template directories.
#
    my $self = shift;
    my ($dir, $file, @dirs);
    my $selected_dir = $self->{cgi}->param('tpl_dir')  || $self->{default_dir} || 'default';
    my $name         = 'tpl_dir';
    
    $dir = $self->{root};
    opendir (TPL, $dir) or die "unable to open directory: '$dir' ($!)";
    while (defined ($file = readdir(TPL))) {
        next if ($file =~ /^\.\.?$/);
        next if ($file eq 'admin' or $file eq 'help');
        next unless (-d "$dir/$file");
        push @dirs, $file;
    }
    closedir (TPL);

    my $d_select_list = "";
    return $d_select_list;
}

sub template_file_stats {
# ------------------------------------------------------------------
# Returns information about a file. Takes the following arguments:
#   - filename
#   - template set
# The following tags are returned:
#   - file_path - the full path to the file, relative to the admin root directory
#   - file_size - the size of the file in bytes
#   - file_local - 1 or 0 - true if it is a local file
#   - file_restore - 1 or 0 - true if it is a local file and a non-local file of the same name exists (The non-local can be restored)
#   - file_mod_time - the date the file was last modified
#
    require GT::Date;
    my ($self, $file) = @_;
    my $tpl_dir       = $self->{cgi}->param('tpl_dir')  || $self->{default_dir} || 'default';    
    my $return = { file_local => 1, file_restore => 1 };
    my $dir = "$self->{root}/$tpl_dir";
    if (-f "$dir/local/$file" and -r _) {
        $return->{file_path} = "templates/$tpl_dir/local/$file";
        $return->{file_size} = -s _;
        $return->{file_local} = 1;
        $return->{file_restore} = (-f "$dir/$file" and -r _) ? 1 : 0;
        my $mod_time = (stat _)[9];
        if ($self->{date_format}) {
            require GT::Date;            
            $return->{file_mod_time} = GT::Date::date_get ($mod_time, $self->{date_format});
        }
        else {
            $return->{file_mod_time} = localtime($mod_time);
        }
    }
    else {
        $return->{file_path} = "templates/$tpl_dir/$file";
        $return->{file_size} = -s "$dir/$file";
        $return->{file_local} = 0;
        $return->{file_restore} = 0;
        my $mod_time = (stat _)[9];
        if ($self->{date_format}) {
            require GT::Date;            
            $return->{file_mod_time} = GT::Date::date_get ($mod_time, $self->{date_format});
        }
        else {
            $return->{file_mod_time} = localtime($mod_time);
        }
    }
    return $return;
}

sub move {
# -------------------------------------------------------------------
# Uses File::Copy to move a file.
#
    my $self = shift;
    my ($from, $to) = @_;
    eval { require File::Copy; };
    if ($@) {
        return $self->error ('FILECOPY', $@);
    }
    File::Copy::mv($from, $to) or return $self->error ('CANTMOVE', $from, $to, "$!");
}

sub copy {
# -------------------------------------------------------------------
# Uses File::Copy to move a file.
#
    my $self = shift;
    my ($from, $to) = @_;
    eval { require File::Copy; };
    if ($@) {
        return $self->error ('FILECOPY', $@);
    }
    File::Copy::cp($from, $to) or return $self->error ('CANTCOPY', $from, $to, "$!");
}

__END__

=head1 NAME

GT::Template::Editor - This module provides an easy way to edit templates.

=head1 SYNOPSIS

Should be called like:

    require GT::Template::Editor;
    my $editor = new GT::Template::Editor (
                    root        => $CFG->{admin_root_path} . '/templates',
                    default_dir => $CFG->{build_default_tpl},
                    backup      => 1,
                    cgi         => $IN
                );
    return $editor->process;

and it returns a hsah ref of variables used for displaying a template editor page.

=head1 COPYRIGHT

Copyright (c) 2001 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Editor.pm,v 2.4 2002/01/07 00:38:39 alex Exp $

=cut

private/lib/GT/Template/Inheritance.pm0100644000076400010020000001725607455656144016506 0ustar  alexcvs# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Template::Inheritance
#   Author: Scott Beck
#   $Id: Inheritance.pm,v 1.3 2002/04/12 22:15:00 jagerman Exp $
#
# Copyright (c) 2002 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: Provides class methods to deal with template
#              inheritance.
#

package GT::Template::Inheritance;
# ==================================================================

use strict;

use vars qw($ATTRIBS $ERRORS);
use bases 'GT::Base' => '';

$ERRORS = {
    NOT_FILE  => q _'%s' does not look like a valid filename_,
    RECURSION => q _Recursive inheritance detected and interrupted: '%s'_
};

sub get_all_paths {
# ----------------------------------------------------------------------------
    my ( $class, %opts ) = @_;

    my $file = delete $opts{file};
    $class->fatal( BADARGS => "No file specified for $class->all_files" )
        unless defined $file;
    
    my $root = delete $opts{path};
    $class->fatal( BADARGS => "No path specified for $class->all_files" )
        unless defined $root;
    $class->fatal( BADARGS => "Path $root does not exist or is not a directory" )
        unless -d $root;
    
    my $use_local = delete $opts{use_local};
    $use_local = 1 unless defined $use_local;

    my $use_inheritance = delete $opts{use_inheritance};
    $use_inheritance = 1 unless defined $use_inheritance;

    my $local_inheritance = delete $opts{local_inheritance};
    $local_inheritance = $use_inheritance unless defined $local_inheritance;

    $class->fatal( BADARGS => "Unknown arguments:(". join(", ", keys %opts).")" )
        if keys %opts;

    my @files;
    while () {
        my ($tplinfo, %tplinfo);
        if ($use_local and -f "$root/local/$file" and -r _) {
            push @files, "$root/local/$file";
            if ($local_inheritance and -f "$root/$file" and -r _) {
                push @files, "$root/$file";
            }
        }
        elsif (-f "$root/$file" and -r _) {
            push @files, "$root/$file";
        }

        require GT::Template if $use_inheritance;
        if (
            $use_inheritance and 
            $tplinfo = GT::Template->load_tplinfo($root) and
            my $inherit = $tplinfo->{inheritance}
        )
        {
            if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
                $root = $inherit;
            }
            else {
                $root .= "/$inherit";
            }
            if (length $root > 150 or $tplinfo{$root}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
                $class->error(RECURSION => WARN => $root);
                last; # End the loop - there is no more inheritance since we would just be recursing over what we already have
            }
        }
        else { # No (more) inheritance, so end the loop
            last;
        }
    }
    return @files;
}

sub get_path {
# ----------------------------------------------------------------------------
    my ( $class, %opts ) = @_;
    my $file = delete $opts{file};
    $class->fatal( BADARGS => "No file specified for $class->all_files" )
        unless defined $file;
    
    my $root = delete $opts{path};
    $class->fatal( BADARGS => "No path specified for $class->all_files" )
        unless defined $root;
    $class->fatal( BADARGS => "Path $root does not exist or is not a directory" )
        unless -d $root;
    
    my $use_local = delete $opts{use_local};
    $use_local = 1 unless defined $use_local;

    my $use_inheritance = delete $opts{use_inheritance};
    $use_inheritance = 1 unless defined $use_inheritance;

    $class->fatal( BADARGS => "Unknown arguments:(". join(", ", keys %opts).")" )
        if keys %opts;

    if ( $use_local and -f "$root/local/$file" and -r _ ) {
        return "$root/local/$file";
    }
    elsif ( -f "$root/$file" and -r _ ) {
        return "$root/$file";
    }
    elsif ( $use_inheritance ) {
        my ($tplinfo, %tplinfo);
        require GT::Template;
        while (
            $tplinfo = GT::Template->load_tplinfo($root) and
            my $inherit = $tplinfo->{inheritance}
        )
        {
            if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
                $root = $inherit;
            }
            else {
                $root .= "/$inherit";
            }
            if ($use_local and -f "$root/local/$file") {
                return "$root/local/$file";
            }
            elsif (-f "$root/$file") {
                return "$root/$file";
            }
            if (length $root > 150 or $tplinfo{$root}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
                return $class->warn(RECURSION => "$root/$file");
                # there is no more inheritance since we would just be recursing over what we already have
            }
        }
    }
    return $class->warn(NO_FILE => $file);
}       

1;

__END__

=head1 NAME

GT::Template::Inheritance - Provides class methods to deal with template
inheritance.

=head1 SYNOPSIS

    use GT::Template::Inheritance;

    my $file = GT::Template::Inheritance->get_path(
        file => "foo.htm",
        path => "/path/to/my/template/set",
        use_local => 1,
        use_inheritance => 1
    );

    my @files = GT::Template::Inheritance->get_all_paths(
        file => "foo.htm",
        path => "/path/to/my/template/set",
        use_local => 1,
        use_inheritance => 1,
        local_inheritance => 1
    );

=head1 DESCRIPTION

GT::Template::Inheritance is a simple module with nothing but class methods
to return the path or paths to files following template inheritace files and
locals. See L for a description of how inheritance and locals
works.

=head1 METHODS

All methods in GT::Template::Inheritance are class methods. Each method takes
a hash of options as an argument.

=head2 get_path

This method returns the path to the proper file given options. The options are
given in the form of a hash.

The following options are required.

=over

=item file

This should be the name of the file you are looking for.

=item path

This should be the path to the template directory you are looking for the file
in.

=back

The following options are not required. If omitted default to on.

=over

=item use_local

This says whether to return the local copy of the file if found rather than
the unmodified copy.

=item use_inheritance

This open specifies whether to search the inheritance tree for the file you
are looking for. The search starts in the C you provided.

=over

=head2 get_all_paths

This method returns all files it finds while looking through inheritance and
or locals.

The following options are required.

=over

=item file

This should be the name of the file you are looking for.

=item path

This should be the path to the template directory you are looking for the file
in.

=back

The following options are not required.

=over

=item use_local

Boolean, should we include files in the local directory if they exist.
Defaults to on.

=item use_inheritance

Boolean, should we search the inheritance tree for files. Defaults to on.

=item local_inheritance

Boolean, should we include both local and root file if they both exist.
Defaults to the value of C.

=back

=head1 SEE ALSO

L

=head1 MAINTAINER

Jason Rhinelander

=head1 COPYRIGHT

Copyright (c) 2002 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Inheritance.pm,v 1.3 2002/04/12 22:15:00 jagerman Exp $

=cut
private/lib/GT/Template/Parser.pm0100644000076400010020000010266207473631762015504 0ustar  alexcvs# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Template::Parser
#   Author: Jason Rhinelander
#   $Id: Parser.pm,v 2.78 2002/05/25 06:49:22 jagerman Exp $
#
# Copyright (c) 2001 Gossamer Threads Inc.  All Rights Reserved.
# ====================================================================
#
# Description:
#   A module for parsing templates. This module actually generates
#   Perl code that will print the template.
#

package GT::Template::Parser;
# ===============================================================

use 5.004_04;
use strict;

use GT::Base;
use GT::Template;

use vars qw(@ISA $TPL $VERSION $DEBUG $ATTRIBS $ERRORS);

@ISA     = qw/GT::Base/;
$VERSION = sprintf "%d.%03d", q$Revision: 2.78 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0;
$ATTRIBS = { root => '.', indent => '  ', begin => '<%', end => '%>', print => 0 };
$ERRORS  = {
    'NOTEMPLATE'        => "No template file was specified.",
    'BADINC'            => "Error: Can't load included file: '%s'. Reason: %s",
    'CANTOPEN'          => "Unable to open template file '%s'. Reason: %s",
    'CANTFIND'          => "Unable to locate template file '%s' in '%s' or any inheritance directories",
    'DEEPINC'           => "Deep recursion in includes, quiting!",
    'EXTRAELSE'         => "Error: extra 'else' tag",
    'LOOPNOTHASH'       => "Error: An iteration of loop variable '%s' returns something other than a hash reference",
    'NOSCALAR'          => "Error: Value not scalar",
    'UNMATCHEDELSE'     => "Error: Unmatched else/elsif/elseif tag",
    'UNMATCHEDENDIF'    => "Error: Unmatched endif/endifnot/endunless tag",
    'UNMATCHEDENDLOOP'  => "Error: endloop found outside of loop",
    'UNMATCHEDNEXTLOOP' => "Error: nextloop found outside of loop",
    'UNMATCHEDLASTLOOP' => "Error: lastloop found outside of loop",
    'UNKNOWNTAG'        => "Unknown Tag: '%s'"
};
 

sub parse {
# ---------------------------------------------------------------
# Can be called as either a class method or object method. This
# returns three things - the first is a scalar reference to a string
# containing all the perl code, the second is an array reference
# of dependencies, and the third is the filetype of the template -
# matching this regular expression:  /^((INH:)*(REL|LOCAL)|STRING)$/.
# For example, 'INH:INH:INH:INH:LOCAL', 'LOCAL', 'INH:REL', 'REL', or 'STRING'
#
    my $self = ref $_[0] ? shift : (shift->new);
    my ($template, $opt, $print) = @_; # The third argument should only be used internally.
    defined $template or return $self->error ('NOTEMPLATE', 'FATAL', $template);
    defined $opt      or  ($opt  = {});

# Set print to 1 if we were called via parse_print.
    if ($print) { $opt->{print} = 1; }

# Load the template which can either be a filename, or a string passed in.
    $self->{root} = $opt->{root} if $opt->{root};

    my ($full, $string);
    my $type = '';
    if (exists $opt->{string}) {
        $full = $template;
        $string = $opt->{string};
        $type = "STRING";
    }
    else {
        my $root = $self->{root};
        until ($full) {
            if (-r "$root/local/$template") {
                $full = "$root/local/$template";
                $type .= "LOCAL";
            }
            elsif (-r "$root/$template") {
                $full = "$root/$template";
                $type .= "REL";
            }
            else { # Try looking in the inheritance tree
                my $tplinfo = GT::Template->load_tplinfo($root);
                if ($tplinfo and my $inherit = $tplinfo->{inheritance}) {
                    if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
                        $root = $inherit;
                    }
                    else { # Relative inheritance path. This might eventually look like /blah/a/../b/../c/../d/../e - Messy, but it works
                        $root .= "/$inherit";
                    }
                    $type .= "INH:";
                }
                else {
                    return $self->error('CANTFIND', 'FATAL', $template, $root);
                }
            }
        }
    }

    $self->load_template($full, $string);

# Parse the template.
    $self->debug ("Parsing '$template' (found '$full') with (print => $opt->{print})") if $self->{_debug};
    my ($code, $deps) = $self->_parse($template, $opt, 1);
    $TPL = '';
    return ($code, $deps, $type);
}

sub parse_print {
# ---------------------------------------------------------------
# Print output as template is parsed.
#
    my $self = shift;
    $self->parse(@_[0..1],1)
}

sub load_template {
# ---------------------------------------------------------------
# Loads either a given filename, or a template string into $TPL.
#
    my ($self, $full_file, $string) = @_;

    if (defined $string) {
        $self->debug("Loading string into \$TPL") if $self->{_debug};
        $TPL = $string;
        return 1;
    }

    $self->debug("Loading '$full_file' into \$TPL") if $self->{_debug};

    -e $full_file              or return $self->error('CANTOPEN', 'FATAL', $full_file, "File does not exist.");
    open (TPL, "< $full_file") or return $self->error('CANTOPEN', 'FATAL', $full_file, $!);
    read TPL, $TPL, -s TPL;
    close TPL;

# Set the last mod time.
    return 1;
}

sub _parse {
# ---------------------------------------------------------------
# Parses a template.
#
    my ($self, $template, $opt) = @_;

    local $self->{opt}     = {};
    $self->{opt}->{print}  = exists $opt->{print}  ? $opt->{print}  : $self->{print};
    $self->{opt}->{indent} = exists $opt->{indent} ? $opt->{indent} : $self->{indent};

    unless (defined $opt->{string}) {
# Set the root if this is a full path so includes can be relative to template.
        if ((not $self->{root} or $self->{root} eq '.') and ((index($template, '/') == 0) or (index($template, ':') == 1))) {
            $self->{root} = substr($template, 0, rindex($template, '/'));
            substr($template, 0, rindex($template, '/') + 1) = '';
        }
    }

    return $self->_parse_tags();
}

sub _text_escape {
    my $text = shift;
    $text =~ s/(\\(?=[{}\\])|[{}])/\\$1/g;
    $text;
}

sub _comment {
    my $comment = shift;
    $comment =~ s/^/#/gm;
    $comment . "\n";
}

sub _parse_tags {
# ---------------------------------------------------------------
# Returns a string containing perl code that, when run (the code should be
# passed a template object as its argument) will produce the template.
# Specifically, the returned from this is a scalar reference (containing the
# perl code) and an array reference of the file's dependencies.
#
    my ($self) = @_;

    my $begin      = quotemeta($self->{begin});
    my $end        = quotemeta($self->{end});
    my $root       = $self->{root};
    my $loop_depth = 0;
    my $i          = -1;
    my @seen_else  = ();
    my $print      = $self->{opt}->{print};
    my $indent       = $self->{opt}->{indent};
    my $indent_level = 0; # The file is already going to be in a hash

    my %deps = ();

    my $last_pos = 0;

# Can only go up to 10 includes inside includes.
    my $include_safety  = 0;

    my $return          = q|
local $^W; # Get rid of warnings. unfortunately, this won't work for Perl 5.6's -W switch
my $self = shift;
my $return = '';
my $escape = $self->{opt}->{escape};
my $strict = $self->{opt}->{strict};
my $tmp;
|;

# We loop through the text looking for <% and %> tags, but also watching out for comments
# <%-- some comment --%> as they can contain other tags.
    my $text = sub {
        my $text = shift;
        length $text or return;
        $return .= ($indent x ($indent_level)) . ($print ? q|print q{| : q|$return .= q{|);
        $return .= (_text_escape($text) . q|};
|)  };
    #while ($TPL =~ /($begin\s*(--(?:(?:$begin\s*--.*?--\s*$end)|.)*?--|.+?)\s*$end)/gs) {
# The above allows 1 level of nested <%-- comments --%>, however it segfaults
# on some systems (Mac OS X) if the overall comment gets too long (even when
# _not_ using the nested comments).
    while ($TPL =~ /($begin\s*(--.*?(?:--(?=\s*$end)|$)|.+?)(\s*(?:$end|$)))/gs) {
        my $tag          = $2;
        my $tag_len      = length($1);
        my $print_start  = $last_pos;
        $last_pos        = pos($TPL);
        my $end_len      = length $3; # This is needed to support nested comments
        # Print out the text before the tag.
        $text->(substr($TPL, $print_start, $last_pos - $tag_len - $print_start));

# Write any comments as Perl comments in the file
        if (substr($tag,0,2) eq '--') {
            my $save_pos = pos($tag);
            while ($tag =~ /\G.*?$begin\s*--/g) {
                $save_pos = pos($tag);
                my $tpl_save_pos = pos($TPL);
                if ($TPL =~ /\G(.*?--\s*$end)/g) {
                    $tag .= $1;
                    pos($tag) = $save_pos;
                    $last_pos = pos($TPL);
                }
                else {
                    $last_pos = pos($TPL) = length($TPL);
                    $tag .= substr($TPL, $last_pos);
                    last;
                }
            }
            my $comment = substr($tag, -2) eq '--' ? substr($tag, 2, -2) : substr($tag, 2);
            $return .= _comment($comment);
            next;
        }

# Tag has no spaces in it.
        if ($tag !~ /\s/) {

# 'else' - If $i is already at -1, we have an umatched tag.
            if ($tag eq 'else') {
                if ($i == -1) {
                    $return .= _comment($ERRORS->{UNMATCHEDELSE});
                    $text->($ERRORS->{UNMATCHEDELSE});
                }
                else {
                    if ($seen_else[$i]++) {
                        $return .= _comment($ERRORS->{EXTRAELSE});
                        $text->($ERRORS->{EXTRAELSE});
                    }
                    else {
                        $return .= $indent x ($indent_level - 1) . q|}
|;                      $return .= $indent x ($indent_level - 1) . q|else {
|;                  }
                }
            }

# 'endif', 'endunless', 'endifnot' - decrement our level. If $i is already at -1, we have an umatched tag.
            elsif ($tag eq 'endif' or $tag eq 'endifnot' or $tag eq 'endunless') {
                if ($i == -1) {
                    $return .= _comment($ERRORS->{UNMATCHEDENDIF});
                    $text->($ERRORS->{UNMATCHEDENDIF});
                }
                else {
                    --$i; --$#seen_else;
                    $return .= $indent x --$indent_level . q|}
|;              }
            }
# 'endloop' - It will help to look for where it writes 'loop' to understand what this does
            elsif ($tag eq 'endloop') {
                if ($loop_depth <= 0) {
                    $return .= _comment($ERRORS->{UNMATCHEDENDLOOP});
                    $text->($ERRORS->{UNMATCHEDENDLOOP});
                }
                else {
                    $loop_depth--;
                    # Close _2_ blocks - one block around the whole thing, and the block for the while loop
                    $return .= $indent x --$indent_level . q|}
|;                  $return .= $indent x --$indent_level . q|}
|;                  $return .= $indent x --$indent_level . q|}
|;                  $return .= $indent x $indent_level . q|for (keys %loop_set) { $self->{VARS}->{$_} = $orig->{$_} }
|;                  $return .= $indent x --$indent_level . q|}
|;              }
            }
# 'lastloop' - simply put in a last;
            elsif ($tag eq 'lastloop') {
                if ($loop_depth <= 0) {
                    $return .= _comment($ERRORS->{UNMATCHEDLASTLOOP});
                    $text->($ERRORS->{UNMATCHEDLASTLOOP});
                }
                else {
                    $return .= $indent x $indent_level . q|last LOOP| . $loop_depth . q|;
|;              }
            }
# 'nextloop' - simply put in a next;
            elsif ($tag eq 'nextloop') {
                if ($loop_depth <= 0) {
                    $return .= _comment($ERRORS->{UNMATCHEDNEXTLOOP});
                    $text->($ERRORS->{UNMATCHEDNEXTLOOP});
                }
                else {
                    $return .= $indent x $indent_level . q|next;
|;              }
            }
# 'endparse' - stops the parser.
            elsif ($tag eq 'endparse') {
                $return .= $indent x $indent_level . q|return | . ($print ? q|1| : q|\$return|) . q|;
|;          }
# 'endinclude' - this is put at the end of an include when the include is inserted into the current template data.
            elsif ($tag eq 'endinclude') {
                $include_safety--;
                $return .= $indent x --$indent_level . q|} # Done include
|;          }
# Function call (without spaces)
            elsif (my $func = $self->_check_func($tag)) {
                $return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|;          }

# Variable
            else {
                $return .= $indent x $indent_level;
                $return .= ($print ? q|print| : q|$return .=|) . q| $tmp if defined($tmp = $self->_get_var(q{| . _text_escape($tag) . q|}, $escape, $strict));
|;          }
        }
# 'if', 'ifnot', 'unless', 'elsif', 'elseif'
        elsif ($tag =~ s/^(if(?:not)?|unless|else?if)\b\s*//) {
            my $op = $1;
            $op = "unless" if $op eq "ifnot";
            $op = "elsif" if $op eq "elseif";
            if ($op eq 'elsif') {
                $return .= $indent x ($indent_level - 1) . q|}
|;              $return .= $indent x ($indent_level - 1) . q|elsif (|;
            }
            else {
                $seen_else[++$i] = 0;
                $return .= $indent x $indent_level++;
                $return .= "$op (";
            }

            my @tests;
            my $bool = '';
            if ($tag =~ /\sor\s*(?:not)?\s/i) {
                @tests = grep $_, split /\s+or\s*(not)?\s+/i, $tag;
                $bool = ' or ';
            }
            elsif ($tag =~ /\sand\s*(?:not)?\s/i) {
                @tests = grep $_, split /\s+and\s*(not)?\s+/i, $tag;
                $bool = ' and ';
            }
            else {
                @tests = $tag;
            }
            if ($tests[0] =~ s/^not\s+//) {
                unshift @tests, "not";
            }
            my @all_tests;
            my $one_neg;
            for my $tag (@tests) {
                if ($tag eq 'not') {
                    $one_neg = 1;
                    next;
                }
                my $this_neg = $one_neg-- if $one_neg;
                $tag =~ s/([\w:-]+)\b\s*//;
                my $var = $1;
                if (index($var, '::') > 0) {
                    $var = $self->_check_func($var);
                }
                else {
                    $var = q|$self->_get_var(q{| . _text_escape($var) . q|}, 0, 0)|;
                }
                my ($comp, $val);
                if (length($tag)) {
                    if    ($tag =~ s/^(==?|!=|>=?|<=?|%|eq|ne|g[et]|l[et])\s*//) { $comp = " $1 " }
                    elsif ($tag =~ s/^(?:like|contains)\s+//i)                   { $comp = 'like' }
                    $val = $tag if defined $comp;
                }
                $comp = ' == ' if $comp and $comp eq ' = ';
                my $full_comp = defined($comp);
                my $result = $this_neg ? 'not(' : '';
                if ($full_comp) {
                    if (substr($val,0,1) eq '$') {
                        substr($val,0,1) = '';
                        $val = q|$self->_get_var(q{| . _text_escape($val) . q|}, 0, 0)|;
                    }
                    elsif ($val =~ s/^(['"])//) {
                        $val =~ s/$1$//;
                        $val = "q{" . _text_escape($val) . "}";
                    }
                    elsif (index($val, '::') > 0) {
                        $val = $self->_check_func($val);
                    }
                    elsif ($val !~ /^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?$/) {
                        $val = "q{" . _text_escape($val) . "}";
                    }
                    if ($comp eq 'like') {
                        $result .= qq|index($var, $val) >= 0|;
                    }
                    elsif ($comp) {
                        $result .= qq|$var $comp $val|;
                    }
                }
                else { # Just a simple <%if var%> (Or something we don't understand, in which case we'll treat it like a simple <%if var%>)
                    $result .= $var;
                }
                $result .= ")" if $this_neg;
                push @all_tests, $result;
            }
            my $final_result = join $bool, @all_tests;
            $return .= $final_result;
            $return .= q|) {
|;      }
# 'loop' - <%loop var%>, <%loop Pkg::Func(arg, $arg => arg)%>, <%loop var(arg, $arg => arg)%>
        elsif ($tag =~ /^loop\b\s*(.+)/s) {
            $loop_depth++;
            my $loopon = $1;
            $return .= $self->_loop_on($loopon, $indent, $indent_level, $loop_depth);
        }

# 'include' - load the file into the current template and continue parsing.
# The template must be added to this template's dependancy list.
        elsif ($tag =~ /^include\b\s*(.+)/) {
            my $include  = $1;
            my ($dep_name, $filename);
            if (-r "$root/local/$include") {
                $dep_name = "LOCAL:$include";
                $filename = "$root/local/$include";
            }
            elsif (-r "$root/$include") {
                $dep_name = "REL:$include";
                $filename = "$root/$include";
            }
            elsif (-r $include) {
                $dep_name = "ABS:$include";
                $filename = "$include";
            }
            else { # Scan the inheritance tree
                my $root = $root; # ;-)
                $dep_name = "INH:";
                until ($filename) {
                    # Try going one more level in the inheritance tree
                    my $tplinfo = GT::Template->load_tplinfo($root);
                    if ($tplinfo and my $inherit = $tplinfo->{inheritance}) {
                        if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
                            $root = $inherit;
                        }
                        else { # Relative inheritance path. This might eventually look like /blah/a/../b/../c/../d/../e - Messy, but it works
                            $root .= "/$inherit";
                        }
                    }
                    else {
                        last; # We haven't found it, and there isn't any (more) inheritance
                    }

                    # Look for the include in the inherited directory:
                    if (-r "$root/local/$include") {
                        $filename = "$root/local/$include";
                        $dep_name .= "LOCAL:$include";
                    }
                    elsif (-r "$root/$include") {
                        $filename = "$root/$include";
                        $dep_name .= "REL:$include";
                    }
                    else {
                        $dep_name .= "INH:";
                    }
                }
            }

            local *INCL;
            if ($filename and open INCL, "<$filename") {
                read  INCL, my $data, -s INCL;
                close INCL;
                substr($TPL, $last_pos - $tag_len, $tag_len) = $data . "$self->{begin}endinclude$self->{end}";
                $last_pos -= $tag_len;
                pos($TPL) = $last_pos;
                $deps{$dep_name} = 1;
                ++$include_safety <= 10 or return $self->error("DEEPINC", 'FATAL');
                $return .= $indent x $indent_level++ . q|{; | # The ; is a fix for empty include files
                    . _comment("Including $filename");
            }
            else {
                my $errfile = $filename || "$root/$include";
                $return .= _comment(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
                $text->(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
                $deps{"MISSING:$include"} = 1;
            }
            next;
        }
# 'escapeURL', 'escape_url', 'unescapeHTML', 'unescape_html', 'escape_js', 'escapeJS' - obvious, I think...
        elsif ($tag =~ /^(escapeURL|escape_url|escapeHTML|escape_html|unescapeHTML|unescape_html|escape_js)\b\s*(\S+)/) {
            my ($type, $var) = ($1, $2);
            $return .= $indent x $indent_level;
            $return .= q|$tmp = $self->_get_value(q{| . _text_escape($var) . q<}, 0) || q{> . _text_escape($var) . q|};
|;          $return .= $indent x $indent_level;
            $return .= q|$tmp = $$tmp if ref($tmp) eq 'SCALAR';
|;          $return .= $indent x $indent_level++;
            $return .= q|if (ref $tmp) {
|;          $return .= $indent x $indent_level;
            $text->($ERRORS->{NOSCALAR});
            $return .= $indent x ($indent_level - 1) . q|}
|;          $return .= $indent x ($indent_level - 1) . q|else {
|;          $return .= $indent x $indent_level;
            if ($type eq 'unescapeHTML' or $type eq 'unescape_html') {
                $return .= ($print ? q|print| : q|$return .=|) . q| GT::CGI::html_unescape($tmp);
|;          }
            elsif ($type eq 'escape_js' or $type eq 'escapeJS') {
                $return .= q{$tmp =~ s{([\\\/'"])}{\\\$1}g; $tmp =~ s{(?:\r\n|\r|\n)}{\\\n}g; };
                $return .= ($print ? q|print| : q|$return .=|) . q| $tmp;
|;          }
            elsif ($type eq 'escape_html' or $type eq 'escapeHTML') { # escapes even a scalar reference
                $return .= ($print ? q|print| : q|$return .=|) . q| GT::CGI::html_escape($tmp);
|;          }
            else {
                $return .= ($print ? q|print| : q|$return .=|) . q| GT::CGI::escape($tmp);
|;          }
            $return .= $indent x --$indent_level . q|}
|;      }
# Also - 'nbsp' - this converts whitespace to  
        elsif ($tag =~ /^nbsp\b\s*(\S+)/) {
            my $var = $1;
            $return .= $indent x $indent_level;
            $return .= q|$tmp = $self->_get_value(q{| . _text_escape($var) . q|}, $strict);
|;          $return .= $indent x $indent_level;
            $return .= q|$tmp = (ref $tmp eq 'SCALAR' ? $$tmp : $escape ? GT::CGI::html_escape($tmp) : $tmp);
|;          $return .= $indent x $indent_level;
            $return .= q|$tmp =~ s/\s/ /g;
|;          $return .= $indent x $indent_level;
            $return .= ($print ? q|print| : q|$return .=|) . q| $tmp;
|;
        }
# 'set' - set a value from the templates
        elsif ($tag =~ m{^set\s*(\w+)\s*([-x+*/%^])?=\s*(.+)}s) {
            my ($var, $change, $val) = ($1, $2 || '', $3);
            $return .= $indent x $indent_level;
            $return .= q|$self->{VARS}->{q{| . _text_escape($var) . q|}} | . $change . q|= |;
            if (substr($val,0,1) eq '$') {
                substr($val,0,1) = '';
                if ($change and $change eq '/' || $change eq '%') {
                    $return .= q|(int($self->_get_var(q{| . _text_escape($val) . q|})) or 1);
|;              }
                else {
                    $return .= q|$self->_get_var(q{| . _text_escape($val) . q|});
|;              }
            }
            elsif (index($val, '::') >= 0) {
                if ($change and $change eq '/' || $change eq '%') {
                    $return .= q|(int(| . $self->_check_func($val) . q|) or 0);
|;              }
                else {
                    $return .= $self->_check_func($val) . q|;
|;              }
            }
            else {
                $val =~ s/^(['"])// and $val =~ s/$1$//;
                if ($change and $change eq '/' || $change eq '%') {
                    $return .= q|(int(q{| . _text_escape($val) . q|}) or 0);
|;              }
                else {
                    $return .= q|q{| . _text_escape($val) . q|};
|;              }
            }
        }
# Look for things like <%... x ...%>, <%... ~ ...%>, etc.
# Also handles <%var += 3%>, <%var 
        elsif ($tag =~ m{^('[^']+'|"[^"]+"|[^\s(]+)\s*(\bx\b|\+|-|\*|/\d+(?=\s)|%|~|\^|\bi/|/)\s*(.+)}s) {
            my $var = $1;
            my $comp = $2;
            my $val = $3;

            if ($var =~ s/^(['"])//) {
                $var =~ s/$1$//;
                $var = q|q{| . _text_escape($var) . q|}|;
            }
            else {
                substr($var,0,1) = '' if substr($var,0,1) eq '$';
                $var = q|$self->_get_var(q{| . _text_escape($var) . q|})|;
            }

            if (substr($val,0,1) eq '$') {
                substr($val,0,1) = '';
                $val = q|$self->_get_var(q{| . _text_escape($val) . q|})|;
            }
            elsif ($val =~ s/^(['"])//) {
                $val =~ s/$1$//;
            }
            elsif (index($val, '::') >= 0) {
                $val = q|(| . $self->_check_func($val) . q< || '')>;
            }
            else {
                $val = q|q{| . _text_escape($val) . q|}|;
            }
            my $calc;

            # Try to do a little bit of basic math.
            # Are we writing a template parser or a programming language? Maybe a bit of both! :)
            if    ($comp =~ /^[x*+-]$/)  { $calc = "+($var $comp $val)" }
            elsif ($comp =~ /^\/(\d+)$/) { $calc = "+sprintf(q{%.$1f}, (((\$tmp = $val) != 0) ? ($var / \$tmp) : 0))" }
            elsif ($comp eq '/')         { $calc = "+(((\$tmp = $val) != 0) ? ($var / \$tmp) : 0)" }
            elsif ($comp eq 'i/')        { $calc = "int(((\$tmp = $val) != 0) ? (int($var) / int(\$tmp)) : 0)" }
            elsif ($comp eq '%')         { $calc = "+(((\$tmp = $val) != 0) ? ($var % \$tmp) : 0)" }
            elsif ($comp eq '~')         { $calc = "+(((\$tmp = $val) != 0) ? (\$tmp - ($var % \$tmp)) : 1)" }
            elsif ($comp eq '^')         { $calc = "+($var ** $val)" }
            $calc ||= '';

            $return .= $indent x $indent_level . ($print ? "print" : q|$return .=|) . " $calc;
";          next;
        }
        elsif (my $func = $self->_check_func($tag)) {
            $return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|;      }
# Check to see if it's a valid variable, function call, etc.
        else {
            $return .= $indent x $indent_level++;
            $return .= q|if (defined($tmp = $self->_get_value(q{| . _text_escape($tag) . q|}, $strict))) {
|;          $return .= $indent x $indent_level;
            $return .= ($print ? q|print| : q|$return .=|) . q|(ref $tmp eq 'SCALAR' ? $$tmp : $escape ? GT::CGI::html_escape($tmp) : $tmp);
|;          $return .= $indent x ($indent_level - 1) . q|}
|;          $return .= $indent x ($indent_level - 1) . q|else {
|;          $return .= $indent x $indent_level;
            $return .= ($print ? q|print q{| : q|$return .= q{|) . _text_escape(sprintf($ERRORS->{UNKNOWNTAG}, $tag)) . q|};
|;          $return .= $indent x --$indent_level . q|}
|;      }
    }
    $text->(substr($TPL, $last_pos));
    while ($indent_level > 0) {
        $return .= ($indent x --$indent_level) . q|}
|   }
    $return .= $print ? q|return 1;| : q|return \$return;|;
    return (\$return, [keys %deps]);
}

sub _loop_on {
    my ($self, $on, $indent, $indent_level, $loop_depth) = @_;

    my $var;

    if (index($on, '::') > 0 or index($on, '(') > 0) {
        $var = $self->_check_func($on);
    }
    else {
        $var = q|$self->{VARS}->{q{| . _text_escape($on) . q|}}|;
    }

    my $print = $self->{opt}->{print};
    my $i0 = $indent x $indent_level;
    my $i = $indent x ($indent_level + 1);
    my $i____ = $indent x ($indent_level + 2);
    my $i________ = $indent x ($indent_level + 3);
    my $i____________ = $indent x ($indent_level + 4);
    my $i________________ = $indent x ($indent_level + 5);
    my $return = <{VARS}}};
${i}my %loop_set;
${i}LOOP$loop_depth: \{
${i____}my \$loop_var = $var;
${i____}my \$loop_type = ref \$loop_var;
${i____}if (\$loop_type eq 'CODE' or \$loop_type eq 'ARRAY') {
${i________}my \$next;
${i________}my \$row_num = 0;
${i________}my \$i = 0;
${i________}my \$current = \$loop_type eq 'CODE' ? \$loop_var->() : \$loop_var->[\$i++];
${i________}if (ref \$current eq 'ARRAY') {
${i____________}\$loop_type = 'ARRAY';
${i____________}\$loop_var = \$current;
${i____________}\$current = \$loop_var->[\$i++];
${i________}}
${i________}next unless ref \$current eq 'HASH'; # It didn't return anything useful
${i________}while (\$current) {
${i____________}if (\$loop_type eq 'CODE') {
${i________________}\$next = \$loop_var->();
${i____________}}
${i____________}else {
${i________________}\$next = \$loop_var->[\$i++];
${i____________}}
${i____________}my \$copy = {\%{\$self->{VARS}}};
${i____________}for (keys %loop_set) {
${i________________}\$copy->{\$_} = \$orig->{\$_};
${i________________}delete \$loop_set{\$_};
${i____________}}
${i____________}if (ref \$current ne 'HASH') { # Whatever they gave us is bad.
${i________________}@{[$print ? 'print' : '$return .=']} q{@{[_text_escape(sprintf($ERRORS->{LOOPNOTHASH}, $on))]}};
${i________________}last LOOP$loop_depth;
${i____________}}
${i____________}for (qw/row_num first last inner even odd/, keys \%\$current) { \$loop_set{\$_} = 1 }
${i____________}\$copy->{row_num} = ++\$row_num;
${i____________}\$copy->{first}   = (\$row_num == 1) || 0;
${i____________}\$copy->{last}    = (!\$next) || 0;
${i____________}\$copy->{inner}   = (!\$copy->{first} and !\$copy->{last}) || 0;
${i____________}\$copy->{even}    = (\$row_num % 2 == 0) || 0;
${i____________}\$copy->{odd}     = (not \$copy->{even}) || 0;
${i____________}for (keys \%\$current) { \$copy->{\$_} = \$current->{\$_} }
${i____________}\$self->{VARS} = \$copy;
${i____________}\$current = \$next;

CODE
    $_[3] += 4; # Update the indent level
    return $return;
}



sub _check_func {
# ---------------------------------------------------------------
# Takes a string and if it looks like a function, returns a string
# that will call the function with the appropriate arguments.
#
# So, you enter the tag (without the <% and %>):
#   <%GFoo::function($foo, $bar, $boo, $far, '7', 'text')%>
# and you'll get back:


#   $self->_call_func('GFoo::function', $self->_get_var(q{foo},0,0), $self->_get_var(q{bar},0,0), ..., q{7}, q{text});


#   <%codevar($foo, $bar, $boo, $far => 7, text)%>
#   $self->_call_func('codevar', $self->_get_var(q{foo},0,0), $self->_get_var(q{bar},0,0), ..., q{7}, q{text});


# NOTE: NO SEMICOLON (;) ON THE END
# which will require GFoo and call GFoo::function with the arguments provided.
#
# If you call this with a tag that doesn't look like a function, undef is returned.
#
    my ($self, $str) = @_;
    my $ret;
    if (((index($str, '(') >= 0 and rindex($str, ')') >= 0) or index($str, '::') >= 1) and $str =~ /^
        (?:
# Package $1
            (
                \w+
                (?:
                    ::
                    \w+
                )*
            )
            ::
        )?
# Function $2
        (
            \w+
        )
        \s*
# Any possible arguments
        (?:
            \(
            \s*
            (
                .+? # Arguments list $3
            )?
            \s*
            \)
        )?
    $/sx) {
        my ($package, $func, $args) = ($1, $2, $3);
        $ret = '';
        my @args = ();
        if ($args) {
            @args = _parse_args ('\s*(?:,|=>)\s*', $args);
            for (@args) {
                if (substr($_, 0, 1) eq '$') {
                    $_ = q|$self->_get_var(q{| . _text_escape(substr($_, 1)) . q|},0,0)|
                }
                else {
                    $_ = q|q{| . _text_escape($_) . q|}|
                }
            }
        }
        $args = join ", ", @args;

        $ret = q|$self->_call_func('| . ($package ? "$package\::$func" : $func) . q|'|;
        $ret .= ", $args" if $args;
        $ret .= ")";
    }
    return $ret;
}

sub _parse_args {
# --------------------------------------------------------
# Splits up arguments on commas outside of quotes. Unquotes
#
    my($delimiter, $line) = @_;
    my($quote, $quoted, $unquoted, $delim, $word, @pieces);
    local $^W;
    while (length($line)) {
        ($quote, $quoted, undef, $unquoted, $delim, undef) =
            $line =~ m/^
                          (["'])                     # a $quote
                              ((?:\\.|(?!\1)[^\\])*) # and $quoted text
                          \1                         # followed by the same quote
                          (.*)                       # and the rest ($+)
                       |                           # --OR--
                       ^  ((?:\\.|[^\\"'])*?)        # $unquoted text, plus:
                          (
                              \Z(?!\n)                  # EOL
                                |
                              (?:$delimiter)            # delimiter
                                |
                              (?!^)(?=["'])             # or quote
                          )
                          (.*)                       # and the rest ($+)
                  /sx;
        return unless($quote or length $unquoted or length $delim);

        $line = $+;

        $unquoted =~ s/\\(.)/$1/g;
        if (defined $quote) {
            $quoted =~ s/\\(.)/$1/g if ($quote eq '"');
            $quoted =~ s/\\([\\'])/$1/g if ( $quote eq "'");
        }
        $word .= defined $quote ? $quoted : $unquoted;
        if (length($delim)) {
            push(@pieces, $word);
            undef $word;
        }
        if (!length($line)) {
            push(@pieces, $word);
        }
    }
    return(@pieces);
}

1;

__END__

=head1 NAME

GT::Template::Parser - The guts of the not-so-simple template parsing module

=head1 SYNOPSIS

This module is not meant to be called directly, and should only be called
from GT::Template.

=head1 SEE INSTEAD

L

=cut
private/lib/GT/FileMan.pm0100644000076400010020000002470207454412344013776 0ustar  alexcvs# ==================================================================
# File manager - enhanced web based file management system
#
#   Website  : http://gossamer-threads.com/
#   Support  : http://gossamer-threads.com/scripts/support/
#   Revision : $Id: FileMan.pm,v 1.101 2002/04/08 22:08:36 tien Exp $
# 
# Copyright (c) 2001 Gossamer Threads Inc.  All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================

package GT::FileMan;
#--------------------------------------------------------------------
    use strict;
    use vars qw/@ISA $DEBUG $HAVE_GZIP $CFG_PATH/;
    use GT::Base qw/:all/;  # Imports $MOD_PERL $SPEEDY $PERSIST
    use GT::Template;
    use GT::FileMan::Commands;

   # Check if Compress::Zlib is available
    $HAVE_GZIP = eval { local $SIG{__DIE__}; require Compress::Zlib; 1; } ? 1 : 0;
    $DEBUG     = 0;

    @ISA = qw/GT::FileMan::Commands GT::Base/;
    $CFG_PATH = 'ConfigData.pm';

sub new {
# ------------------------------------------------------------------
# Constructor
#
    my ($class,%args) = @_;
    my $self = bless {%args}, ref $class || $class;

    $self->{cfg}                    = $self->load_config() if (!$self->{cfg});
    $self->{cfg}->{winnt}           = $^O eq 'MSWin32' ? 1 : 0;
    $self->{cfg}->{template_root}   or die('You must pass in your template root !');
    $self->{cfg}->{root_dir}        or die('You must set your root dir !');
            
    $self->{in}         = new GT::CGI;
    $self->{cgi}        = $self->{in}->get_hash;

    my $passwd_dir = $self->{passwd_dir};
    if ($passwd_dir and !$self->{in}->cookie('def_passwd_dir')) { #store the password directory to cookie
        $passwd_dir = "$self->{cfg}->{root_dir}/$passwd_dir" if ($self->{cfg}->{passwd_dir_level}); # must be inside root directory

        (-e $passwd_dir and -w _) or die("$passwd_dir does not exist or not writeable");
        print $self->{in}->header (-cookie => [ $self->{in}->cookie ( -name => 'def_passwd_dir', -value => $passwd_dir, -expires => '+5y') ]);
    }

# Set our default working directory.
    $self->{work_path}  = $self->{cgi}->{work_path};
    if ($self->{cgi}->{def_load} and !$self->{cgi}->{work_path}) {
        $self->{work_path} = ($self->{in}->cookie('def_working_dir') eq '/') ? '' : $self->{in}->cookie('def_working_dir');
        (!$self->{work_path} or ($self->{work_path} =~ m,^([-\w/. ]+)$, and $self->{work_path} !~ /(\.\.)+/)) or ($self->{work_path} = '');
    }
    $self->{work_path} ||= '';
    (!$self->{work_path} or ($self->{work_path} =~ m,^([-\w/. ]+)$, and $self->{work_path} !~ /(\.\.)+/)) or die ("work_path has invalid characters : $self->{work_path} ");
    -e "$self->{cfg}->{root_dir}/$self->{work_path}" or ($self->{work_path} = '');

    $self->{http_ref}  = $self->{in}->url (absolute => 0, query_string => 0);
    $self->{results}   = '';
    $self->{data}      = {};  
    $self->{status}    = '';
    $self->{input}     = '';   
    $self->{debug}     and ($DEBUG = $self->{debug});
    return $self;
}

sub process {
# ------------------------------------------------------------------
    my $self    = shift;
    my $action  = $self->{cgi}->{fdo} || $self->{cgi}->{cmd_do};
     
    return $self->page("home.html") if (!$action or $action eq 'fileman');     
     
    my $command_enable = 1; # default is enable
    $command_enable    = $self->{commands}->{$action} if (exists $self->{commands}->{$action});
    
# Determine what to do:    
    if (exists $GT::FileMan::Commands::COMPILE{$action} and $command_enable) { 
        $self->$action();
    }
    else {
        die "Invalid action or command is disable : $action !";
    }
}

sub page {
# ------------------------------------------------------------------
#   Print out the requested template
#
    my ($self,$file,$args) = @_;
    $file ||= $self->{cgi}->{page};
    print $self->{in}->header;

# Check the file name requested.
    $file =~ /\\/                            and return die "Invalid template '$file' requested (Invalid name)";
    $file =~ /\.\./                          and return die "Invalid template '$file' requested (Invalid name)";
    $file =~ m,^\s*/,                        and return die "Invalid template '$file' requested (Invalid name)";
    -e "$self->{cfg}->{template_root}/$file" or return  die "Invalid template '$self->{cfg}->{template_root}/$file' requested (File does not exist)";
    -r _                                     or return  die "Invalid template '$file' requested (Permission denied)";

# Make data available.
    foreach my $key (keys % {$self->{data}}) {
        exists $args->{$key} or $args->{$key} = $self->{data}->{$key};
    }

# Make cgi input available.
    foreach my $key (keys % {$self->{cgi}}) {
        exists $args->{$key} or $args->{$key} = $self->{cgi}->{$key};
    }

# Make commands available.    
    my $count = 0;
    if ($self->{commands}) { #activate or deactivate the commands
        foreach my $key (keys % {$self->{commands}}) {
            exists $args->{$key} or $args->{$key} = $self->{commands}->{$key};
            $count++;
        }
    }

    $args->{show_all}   = '1' if ($count == 0);    
    $args->{status}   ||= $self->{status};
    $args->{input}      = $self->{input};    
    $args->{http_ref}   = $self->{http_ref};
    $args->{url_opts}   = $self->{url_opts};
    $args->{work_path}  = $self->{work_path} || $self->{cgi}->{work_path};
    $args->{template_root} = $self->{cfg}->{template_root};
 
    $args->{root_dir}       = $self->{cfg}->{root_dir};
    $args->{html_url}       = $self->{cfg}->{html_root_url};
    $args->{root_select}    = $self->{cfg}->{root_select}    if ($self->{cfg}->{root_select});
    $args->{session_id}     = $self->{cfg}->{session_id}     if ($self->{cfg}->{session_id});
    $args->{user_sessions}  = $self->{cfg}->{user_sessions}  if ($self->{cfg}->{user_sessions});
    $args->{username}       = $self->{cfg}->{username}       if ($self->{cfg}->{username});
    $args->{multi}          = $self->{cfg}->{multi}          if ($self->{cfg}->{multi});
    $args->{single}         = $self->{cfg}->{single}         if ($self->{cfg}->{single});
   
    $args->{have_gzip}      = $HAVE_GZIP;
    $args->{srv_soft}       = ($ENV{SERVER_SOFTWARE} =~ m,Apache,)? 0 : 1 if ($ENV{SERVER_SOFTWARE});
    $args->{position}       = $self->{in}->cookie('readme_position') if ($args->{readme});

    $args->{scheme}         = $self->{in}->cookie('scheme') || 'fileman';
    $args->{font}           = $self->{in}->cookie('font')   || "";
    $args->{font}           =~ s/[\'\"]/\'/g;

    if ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i and $ENV{HTTP_USER_AGENT} !~ /mac/i) {
        $args->{is_ie} = 1;
        $args->{ie_version} = $1;
    }
# Export home for using in auto generate HTML.
    GT::Template->parse ("$self->{cfg}->{template_root}/$file", $args, { print => 1 });
}

sub load_config {
# --------------------------------------------------------------------
# Load the config file into a hash.
#
    my $self = shift;
    my $cfg  = do $CFG_PATH;
    if (ref $cfg ne 'HASH') {
        die "Invalid config file, got: $cfg instead of actual data: $@ $!";
    }
    return $cfg;
}

sub fatal {
# --------------------------------------------------------------
# Return a fatal error message to the browser.
#
    die @_ if (GT::Base->in_eval());    # Don't do anything if we are in eval.

    my $msg   = shift;
    my $in    = new GT::CGI;
    print $in->header;

    my $work_path = $in->param('work_path') || '';

    print qq!
            A fatal error has occured:
$msg
Please enable debugging in setup for more details.
\n
    !;
    if ($DEBUG) {
        print base_env();
    }
}

sub base_env {
# --------------------------------------------------------------------
# Return HTML formatted environment for error messages.
#
    my $info = '
';

# Stack trace.
    my $i = 0;
    $info .= "Stack Trace\n======================================\n";
    $info .= GT::Base::stack_trace('FileMan', 1, 1);
    $info .= "\n\n";

    $info .= "System Information\n======================================\n";
    $info .= "Perl Version: $]\n";
    $info .= "FileMan Version: $FileMan::VERSION\n" if ($FileMan::VERSION);
    $info .= "Persistant Env: mod_perl ($MOD_PERL) SpeedyCGI ($SPEEDY)\n";
    $info .= "Mod Perl Version: $mod_perl::VERSION\n" if (defined $ENV{GATEWAY_INTERFACE} and ($ENV{GATEWAY_INTERFACE} =~ /perl/i));
    $info .= "\@INC = \n\t" . join ("\n\t", @INC) . "\n";
    $info .= "\$\@: $@\n" if ($@);
    $info .= "\n";

# Environment info.
    $info  .= "ENVIRONMENT\n======================================\n";
    foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
    $info .= "
";
    return $info;
}


sub js_quote_include {   
# --------------------------------------------------------------------    
# This uses GT::Template to parse the passed in argument. The results are
# javascript escaped, and then returned.
#
    my $file = shift;
    my $tags = GT::Template->tags;    

    my $in   = new GT::CGI;
    my $css_file = $in->cookie('scheme') || 'fileman';
    my $color;
    CASE: {
        ($css_file eq 'fileman') and $color = '#D6D6D6', last CASE;
        ($css_file eq 'gt')      and $color = '#d9e4f2', last CASE;
        ($css_file eq 'maple')   and $color = '#F0E8CE', last CASE;
        ($css_file eq 'rainy')   and $color = '#CFD8C2', last CASE;
        ($css_file eq 'rose')    and $color = '#DEC9CE', last CASE;
    }
    my $parsed = GT::Template->parse("$tags->{template_root}/common/$file", 
                                              {  
                                                html_url                    => $tags->{html_url},
                                                scrollbar_arrow_color       => 'black',
                                                scrollbar_base_color        => $color,
                                                editor_base_color           => $color,
                                                advanced_editor_background  => 'white',
                                                advanced_editor_font        => 'arial'
                                               });
    $parsed =~ s{([\\/'"<>])}{\\$1}g;
    $parsed =~ s/(?:\r\n|\r|\n)/\\n/g;
    return \$parsed;
}

1;
private/lib/GT/FileMan/0040755000076400010020000000000007477023142013435 5ustar  alexcvsprivate/lib/GT/FileMan/Commands.pm0100644000076400010020000036146007476773514015561 0ustar  alexcvs# ==================================================================
# File manager - enhanced web based file management system
#
#   Website  : http://gossamer-threads.com/
#   Support  : http://gossamer-threads.com/scripts/support/
# 
# Copyright (c) 2001 Gossamer Threads Inc.  All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================

package GT::FileMan::Commands;
# ===============================================================
    use strict;
    use GT::TempFile;
    use vars qw/@ISA $COPIED $ICONS $DEBUG $AUTOLOAD $READ_SIZE %LANGUAGE/;
    use GT::Base qw/:all/;  # Imports $MOD_PERL $SPEEDY $PERSIST
    use GT::AutoLoader;

# Our nasty language hash.
    %LANGUAGE = (
        UPLOAD_MODE         => "File %s was successfully uploaded in %s mode.",    
        MSG_LOG_OFF         => "Please enter username and password to login.", 
        MSG_MULTI_UPLOAD    => "%s files have been successfully uploaded.",
        MSG_CHMOD_CHANGED   => "Permissions on %s file(s) have been updated successfully.",
        MSG_SEACH_FOUND     => "Your search found %s results.",
        MSG_REPLA_FOUND     => "Your search and replace updated %s files in %s",
        MSG_SEACH_NOTFOUND  => "Your search did not produce any results.",
        MSG_FILE_EDITING    => "%s %s file ... (size %s bytes)- Download",
        MSG_FILE_CREATED    => "%s has been created.",
        MSG_FILE_EDITED     => "Changes to %s have been saved.",
        MSG_DIR_CREATED     => "%s directory has been created.",
        MSG_PREFERENCES     => "Your options have been saved.",
        MSG_UNCOMPRESS      => "%s file has been unarchived.",
        MSG_TAR_CANCEL      => "Creation of tar file has been cancelled.",
        MSG_TAR_CREATED     => "Tar file %s has been created.",                    
        MSG_COPY_CANCEL     => "Copy of %s file(s) has been canclled.",
        MSG_COPIED          => " %s selected file(s) have been %s.",
        MSG_MOVED           => " %s selected file(s) have been %s (%s can not be moved).",
        MSG_DEL_SUCC        => "%s files and %s directories have been removed.",
        MSG_DEL_CURR        => "You've removed the directory: %s",
        MSG_DEL_ALL         => "You've removed the directory, and all contents recursively.",
        MSG_DEL_SKIP        => "You've skiped the directory :%s",
        MSG_DEL_CANC        => "You've cancelled deleting the directory",
        MSG_DEL_ALL_SUCC    => "All child dirs and files on the selected directorys has been removed. ",
        MSG_CONTINUE        => " click here to continue.",
        MSG_PWD_CHANGED     => "Your password was changed. ",
        MSG_DEMO            => "Disabled in Demo.",
        ERR_DEL             => "Can not remove file(s)",
        ERR_CHMOD           => "Can not change mode ",
        ERR_FILE_OPEN       => "Can not open file: %s",
        ERR_FILE_EMPTY      => "File %s is empty: $!",
        ERR_FILE_EXISTS     => "File %s exists.",
        ERR_FILE_NOT_EXISTS => "File %s not exists.",
        ERR_FILE_PERM       => " Sorry, but we don't have write access to the htaccess files: '%s' and '%s'",
        ERR_FILE_PEM        => "The %s directory is not writeable.",
        ERR_NOT_TEXT_FILE   => "File %s is not a text file.",
        ERR_DIR_NOT_EXISTS  => "Directory %s not exists.",
        ERR_DIR_PEM         => "The %s file is not writeable.",
        ERR_DIR_PERM        => "Please check permission.",
        ERR_NOT_ISFILE      => "%s is a directory.",
        ERR_TMP_FILE        => "Can not open temp file.",
        ERR_FREE_SPC        => "Upload: Not enough free space to upload that file.",
        ERR_RM_FILE         => "Unable to remove file: %s. Reason: %s",
        ERR_UPLOAD          => "Unable to upload file: %s. Reason: %s.",
        ERR_FILE_SAVE       => "Cannot save file %s. Check permissions.",
        ERR_DIR_EXISTS      => "Directory %s already exists.",
        ERR_NAME            => "Illegal Characters in Directory. Please use letters, numbers, - and _ only.",
        ERR_FILE_NAME1      => "No double .. allowed in file names.",
        ERR_FILE_NAME2      => "No leading . in file names.",
        ERR_READ_DIR        => "Can not open dir: %s. Reason: %s",
        ERR_DIR_DEEP        => "Directory level too deep.",
        ERR_DISK_SPACE      => "Not enough space to save it (free space is %s kb)",
        ERR_UNCOMPRESS      => "Select files or directories before to uncompress.",
        ERR_TAR             => "Error: %s.",
        ERR_TAR_NOT_EXISTS  => "Can not create a tar file: %s",
        ERR_TAR_PEM         => "Can not create a tar file %s. Check permission.",                    
        ERR_DOWNLOAD        => "You selected a directory !",
        ERR_LOGIN           => "Invalid Username and Password.",
        ERR_INVALID         => "Input value has invalid characters : %s ",
        ERR_NOT_FILE        => "The %s is not a file",
        ERR_OLD_PASSWORD    => "Invalid Old password",
        ERR_NEW_PASSWORD    => "New password must be more than 3 character",
        ERR_OPEN_FILE       => "Can not open %s file, reason: %s ",
        ERR_WRITEABLE       => "Can not save %s file, reason: %s ",
        COBALT_NOREMOTE     => "FileMan is not currently running under server authentication!",
        ERR_VERSION         => "This action does not support for your current version!",
        COBALT_NOUSER       => "Unable to lookup user '%s'",
        COBALT_BADUID       => "Invalid user '%s' (%s)",
        COBALT_CANTSU       => "Can't switch to user '%s' (%s,%s). Reason: '%s'",
        COBALT_BADDIR       => "Invalid home directory '%s'. It does not look like a standard Raq director.",
        COBALT_BADGROUP     => "This program is restricted to site administrators only. You must be in the site administer group in order to use this."
    );

# Mapping of image name to icon files.
    $ICONS = {
        'gif jpg jpeg bmp'      => ['image2.gif' => 'Image File'],
        'txt'                   => ['text.gif' => 'Text File'],
        'cgi pl pm'             => ['text.gif' => 'Script File'],
        'zip gz tar'            => ['compressed.gif' => 'Compressed File'],
        'htm html shtm shtml'   => ['ie.gif' => 'Html File'],
        'wav au mid mod'        => ['sound1.gif' => 'Sound File'],
        'exe'                   => ['binary.gif' => 'Binary File'],
        'doc'                   => ['doc.gif' => 'MS Word'],
        'xls'                   => ['xls.gif' => 'MS Excel'],
        'pdf'                   => ['pdf.gif' => 'Adobe Acrobat'],
        'unknown'               => ['unknown.gif' => ''],
     };  

# How large a chunk should we read into memory at once.
    $READ_SIZE = 500000;

sub DESTROY {}

$COMPILE{cmd_main_display} = __LINE__ . <<'END_OF_SUB';
sub cmd_main_display {
# ------------------------------------------------------------------
# Display main page
#
    my ($self,$args,$type) = @_;
    $self->list_files();
    $self->{cgi}->{cmd_do} = 'cmd_command' if ($type);
    $self->page('main.html',$args); 
}
END_OF_SUB

sub list_files {
# ------------------------------------------------------------------
# Displays a list of files for a given work_path.
#
    my $self            = shift; 
    my $do              = shift || 'cmd_main_display';
    my $only_dir        = $self->{cfg}->{only_dir}; #only display directory listings
    my $work_path       = $self->{work_path};
    my $real_work_path  = $self->_safe_dir();
    my $html_url        = $self->{cfg}->{html_root_url} || '';
    my $url_opts        = $self->{url_opts}             || '';
    my $url             = "$self->{http_ref}?fdo=$do&$url_opts";
    my $list;

# Check if we have data already to list
    if (ref $self->{results} eq 'ARRAY') {
        $list = $self->{results};
    }
    else {

# Else get the list of files using readdir.    
        opendir (DIR, $real_work_path) or die sprintf ($LANGUAGE{ERR_READ_DIR}, $real_work_path, "$!");
        @$list = readdir(DIR);
        closedir (DIR);
    } 

# Create path string
    my $path = [];
    $path    = [split /\//, $self->{work_path}] if ($self->{work_path});
    my ($string, $spath);
    my $parent = '';
    $string    = 'root:  ' ;
    for my $ii ( 0.. $#$path) {
        (@$path[$ii] eq '') and next;
        $spath  .= (($spath)?'/':'').@$path[$ii];
        $parent .= (($parent)?'/':'').@$path[$ii] if ($ii < $#$path);
        $string .= "/".@$path[$ii]."";
    }
    
# Create data array to sort
    my ($list_dir, $list_file, $readme, $num_objects, $total_space);
    foreach my $file (@$list) {
        ($file eq '.')  and next;      
        ($file eq '..') and next;
        (!$self->{in}->cookie('hidden_file') and $file =~ /^\./) and next; #don't show hidden file
        my $fullfile = "$real_work_path/$file";
        ($only_dir and (!-d $fullfile)) and next; # next if not directory

        my @stat     = stat($fullfile);
        my $hash;
        $readme = $file if (uc($file) eq 'README');
        @$hash{'name','size','date','perm','nsize'} = ($file, $stat[7], $stat[9], $stat[2],$stat[7]);
        $hash->{user} =  eval { getpwuid($stat[4]); } || '';
        $num_objects++;

        if (-d $fullfile) {
            ($file =~ /^\./ or !-x $fullfile) and $hash->{disabled} = 1;
            $hash->{nsize} = 0;
            push @$list_dir, $hash;
        }
        else {
            $hash->{type} = _get_icon($file)->{type};
            (-r $fullfile) or $hash->{disabled} = 1;
            $total_space += $hash->{size};
            push @$list_file,$hash;
        }
    }
    my $orderby  = $self->{cgi}->{sb} || $self->{in}->cookie('def_sort') || 'name';  
    my $sortdown = !$self->{cgi}->{sd};
    ($#$list_file > 0) and $list_file = $self->qsort($list_file,$orderby,$sortdown);
    ($#$list_dir  > 0) and $list_dir  = $self->qsort($list_dir,$orderby,$sortdown);

# Get the full filename, file size, file modification date and file permissions.    
    foreach  (@$list_dir) {
        $_->{icon} = "";
        $_->{isdir}= '1';
        $_->{type} = 'File Folder';
        $_->{size} = '';
        $_->{date} = _get_date($_->{date});
        $_->{perm} = _print_permissions($_->{perm});

    }  
    foreach  (@$list_file) {
        my $spec   = _get_icon($_->{name});
        $_->{icon} = "{icon}."' width=14 height=16>";
        $_->{isdir}= '0';
        $_->{size} = _print_filesize($_->{size});
        $_->{date} = _get_date($_->{date});
        $_->{perm} = _print_permissions($_->{perm});
    }
    
    my $sorted; 
    my $output;
    @$sorted = ($sortdown) ? (@$list_dir, @$list_file) : (@$list_file, @$list_dir);
    my $speed_bar;    

# Prepare output after sort    
# Skip pages
    my $pg          = $self->{cgi}->{pg} || 1; #current page
    my $r_pg        = $self->{in}->cookie('def_files_page') || 25;
    my $count       = 0;
    my $def_files   = $self->{in}->cookie('def_files_page') || '';
    if ($def_files ne 'all' and $pg ne 'all'){
        my $skip = 0;
        foreach (@$sorted) {
            $skip++;
            if (($#$sorted > $r_pg) and ($pg > 0)) { 
                my $r_start = ($pg == 1)? 1 : (($pg - 1)*$r_pg + 1);            
                ($skip < $r_start) and next;
                $count++;
                ($count > $r_pg) and last;
            }
            push @$output,$_;
        }
        $speed_bar = $self->speed_bar($#$sorted) if (($#$sorted + 1) > $r_pg);
    }
# else all rows
    else {
        $speed_bar = $self->speed_bar($#$sorted) if (($#$sorted + 1) > $r_pg and $pg eq 'all');
        $output    = $sorted;
    }
    $self->{work_path} and unshift @$output,{'icon' => "",
                                       'name' => "Parent Directory",
                                       'type' => '', 'size' => ' ', 'date' => ' ', 'perm' => '', 'user' => ' '};

# Build columns title
    my $sort_title;
    my $cols;
    @$cols{'name','size','date','perm','user','type','view'} = ('Name','Size','Modified','Permissions','Owner','File Type','View');
    foreach  (keys %$cols) {
        my $temp = "{$_}.'' ;
        $temp .= ( ( $_ eq $orderby ) ? ( ($sortdown) ? " ^" : " v" ) : '' );
        $sort_title->{'s'.$_} = $temp;
    }
    
    my ($msg_readme);
    if ($readme) {
        $msg_readme = "
Readme File:";
        open (DATA, "<$real_work_path/$readme") or return $self->cmd_main_display({reload => 1, status => "$!"});
        $count = 0;
        while () {
            chomp;
            next if ( $_ =~ /^\#/ or !$_);
            $msg_readme .= (($msg_readme)? "
":"").$_;
            $count++;
            last if ($count == 10);
        }
        close DATA;
        $msg_readme .= "
";
    }    
# Return data
    $self->{data} =  {
             pg             => $pg, %$sort_title,
             string         => $string, 
             results        => $output, 
             speed_bar      => $speed_bar, 
             readme         => $msg_readme,
             num_objects    => $num_objects,
             total_space    => $total_space,
             count          => ($count)?(($count > 10)?$count-1:$count) : $#$output + 1
             };

}

$COMPILE{cmd_show} = __LINE__ . <<'END_OF_SUB';
sub cmd_show {
# ------------------------------------------------------------------
# display with unusual template
#
    my ($self,$args) = @_;
    $args ||= {};
    my $template = $self->{cgi}->{page} || 'file_editor.html';
    
    my $ie = ($ENV{HTTP_USER_AGENT} =~ m,MSIE 5.5, or $ENV{HTTP_USER_AGENT} =~ m,MSIE 6,) ? 1 : 0;    
    if ($template eq 'file_editor.html') {
        ($args->{use_html}) and $self->{cgi}->{content} =~ s/
{cgi}->{content} = $self->{in}->html_escape($self->{cgi}->{content}) if ($self->{cgi}->{content});        
        return $self->page($template,{ use_html => ( !$self->{in}->cookie('editor_mode') and $ie ) ? 1 : 0,
                                       rows     => $self->{in}->cookie('rows') || 20,
                                       cols     => $self->{in}->cookie('cols') || 100,
                                       %$args
        });
    }
    elsif ($template eq 'preferences.html') {
        my $def_passwd_dir = $self->{in}->cookie('def_passwd_dir') || $self->{cgi}->{def_passwd_dir};
        $def_passwd_dir =~ s/$self->{cfg}->{root_dir}\/// if (!$self->{cfg}->{passwd_dir_level});

        return $self->page($template,{ def_sort            => $self->{in}->cookie('def_sort')         || $self->{cgi}->{def_sort} ,
                                       def_working_dir     => $self->{in}->cookie('def_working_dir')  || $self->{cgi}->{def_working_dir},
                                       def_passwd_dir      => ($def_passwd_dir eq '0') ? '' : $def_passwd_dir,
                                       def_files_page      => $self->{in}->cookie('def_files_page')   || 25,
                                       def_pages_screen    => $self->{in}->cookie('def_pages_screen') || 20,
                                       readme_position     => $self->{in}->cookie('readme_position')  || 'Y',
                                       hidden_file         => $self->{in}->cookie('hidden_file')      || '0',
                                       editor_mode         => $self->{in}->cookie('editor_mode')      || '0',
                                       passwd_dir_level    => $self->{cfg}->{passwd_dir_level},
                                       ie                  => $ie, %$args
        });
    }
    $self->page ($template,$args);    
}
END_OF_SUB

$COMPILE{cmd_cd} = __LINE__ . <<'END_OF_SUB';
sub cmd_cd {
#------------------------------------------------------------------
# CD command
#
    my $self = shift;
    my $result = $self->_cd_check();
    ($result->{status}) and return $self->cmd_main_display({reload => 1, status => $result->{status}},1); # not safe            
    $self->{work_path} = $result->{work_path};
    $self->cmd_main_display();
}
END_OF_SUB

sub _cd_check {
#----------------------------------------------------------------
# check cd command
#
    my $self = shift;    
    my $input     = $self->{cgi}->{txt_input};
    my $root_path = $self->{cfg}->{root_dir};
    my $fulldir   = $self->_safe_dir($input,{ exist => 1, write => 1});    
    ($fulldir == -1)  and return {status => sprintf($LANGUAGE{ERR_INVALID},$input), work_path => ''}; # not safe
    $fulldir->{exist}  or return {status => sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS},$input),work_path => ''}; # not exist
    my $dir = $fulldir->{fulldir};
    $dir =~ s,$root_path/,,;
    return { status => '', work_path => $dir};
}

$COMPILE{cmd_search} = __LINE__ . <<'END_OF_SUB';
sub cmd_search {
#----------------------------------------------------------------
#   Search command
#
    my ($self, $repl) = @_; 
    
    my ($results, $string, $spath);    
    my $sortdown    = !$self->{cgi}->{sd};
    my $work_path   = $self->{work_path}                    || ''; 
    my $orderby     = $self->{cgi}->{sb}                    || $self->{in}->cookie('def_sort') || 'name';
    my $pg          = $self->{cgi}->{pg}                    || '1'; #current page
    my $r_pg        = $self->{in}->cookie('def_files_page') || '25';    
    my $search      = $self->{cgi}->{txt_input};     
    $pg = 'all' if ($r_pg eq 'all');
    my $r_start;
    $search =~ s/[\*\/\\]//g;   

    my $url_opts= $self->{url_opts} || '';

# Initial value for url
    my $scope   = $self->{cgi}->{scope};
    my $src_opts= "scope=$scope&c_case=$self->{cgi}->{c_case}&c_content=$self->{cgi}->{c_content}"; 
    my $url     = "$self->{http_ref}?fdo=cmd_main_display&$url_opts";
    my $url_pg  = "$self->{http_ref}?cmd_do=cmd_search&cmd=search&txt_input=".(($repl)?$self->{cgi}->{txt_with}:$search)."&work_path=$work_path&$url_opts";
    my $path    = [split /\//,$work_path];      

# Select files from selected files
    my $files;
    if (! $scope) { # All of root
        my $fulldir = $self->_safe_dir();        
        $files      = ($repl)? subdir(1,1, $fulldir) : subdir(0,1, $fulldir);
    }
# Selected files
    else { 
        my $selected = [$self->{in}->param('c_edit')];
        foreach (@$selected) {            
            my $fulldir = $self->_safe_dir($_);
            next if ($fulldir == -1);

            my $tmp = ($repl)? subdir(1,1, $fulldir->{fulldir}) : subdir(0,1, $fulldir->{fulldir});
            push @$files, @$tmp;
            $src_opts .= "&c_edit=$_";
        }                        
    }
    $url_pg .= "&$src_opts";

# Search data
    if ($repl) { # replace        
        $results = $self->_replace($files);               
    } 
    else { # search data
        if (!$self->{cgi}->{c_content}) { # file name
            foreach (@$files) {
                my $name = $_->{name};
                if ($self->{cgi}->{c_case}) { # None Case Sensitive 
                    push @$results, $self->_file_info("$_->{parent}/$_->{name}") if ($name =~ m,$search,);
                }
                else {
                    push @$results, $self->_file_info("$_->{parent}/$_->{name}") if ($name =~ m,$search,i);
                }
            }
        }
        else { # contents
            $results = $self->_search($files);
        }
    }

#Push data of current page into an output array.
    my ($skip,$output,$total_space);
    if ($pg eq 'all') {
        $output = $results;
    }
    else {
        $r_start = ($pg == 1)? 0 : (($pg - 1)*$r_pg );
        for my $ii ( 0 .. $#$results) {                
            $total_space +=  @$results[$ii]->{size};
            if ($ii >= $r_start and $#$output < $r_pg-1) {
                push @$output,@$results[$ii];
            }
        }
    }
    $string = 'root:  ';
    for my $ii ( 0.. $#$path) {
        (@$path[$ii] eq '') and next;
        $spath   .= (($spath)? '/':'') . @$path[$ii];     
        $string  .= "/".@$path[$ii]."";
    }    
    my $msg;
    if ($#$results >= 0) {
        $msg = ($repl)? sprintf ($LANGUAGE{MSG_REPLA_FOUND}, $#$results+1, ($scope)? '' : 'in ' . (($work_path)? '/' : 'Root').$work_path)
                      : sprintf ($LANGUAGE{MSG_SEACH_FOUND}, $#$results+1, ($scope)? '' : 'in ' . (($work_path)? '/' : 'Root').$work_path);
    }
    else {        
        $msg = $LANGUAGE{MSG_SEACH_NOTFOUND};
    }
    
# Sort data 
    my ($cols,$sort_title);    
    @$cols{'name','size','date','perm','user','type','view'} = ('Name','Size','Modified','Permissions','Owner','File Type','View');
    foreach  (keys %$cols) {
        my $temp = "{$_}."" ;
        $temp .= ( ( $_ eq $orderby ) ? ( ($sortdown) ? "  ^" : "  v" ) : '' );
        $sort_title->{'s'.$_} = $temp;
    }

# Create speed bar
    my $speed_bar;
    $speed_bar = $self->speed_bar($#$results,"$url_pg&sb=$orderby") if (($#$results - 1) > $r_pg and $r_pg > 0);  
    ($#$output>1) and $output = $self->qsort($output,$orderby,$sortdown);
    foreach (@$output) {
        $total_space += $_->{size} if ($pg eq 'all');
        $_->{size} = _print_filesize($_->{size});
        $_->{perm} = _print_permissions($_->{perm});
        $_->{date} = _get_date($_->{date});
    }
    $self->{data} = {url        => "$self->{http_ref}",
                     results    => $output,%$sort_title,
                     string     => $string,
                     reload     => '1',
                     total_space=> $total_space,
                     num_objects=> (($#$results >=0)? $#$results+1:0),
                     status     => "$msg",
                     speed_bar  => $speed_bar,
                     search     => 1};
    $self->page('main.html',{reload=>1});  
}

sub _search {
#-------------------------------------------------------------------
# search contents
#
    my ($self,$files) = @_;

    my $results;
    my $search = $self->{cgi}->{txt_input};        
    if ($self->{cgi}->{c_regex}) { $search = quotemeta($search); }    
    foreach (@$files) {
        my $file = ($_->{name})? "$_->{parent}/$_->{name}" : $_->{parent};

        if (-T $file) { # Text file
            next if (!open(SOURCE, "< $file"));
            my $buffer;
            if (-s SOURCE < $READ_SIZE) {
                read (SOURCE, $buffer, -s SOURCE);
                if ($self->{cgi}->{c_case}) { # None Case Sensitive 
                    push @$results, $self->_file_info($file) if ($buffer =~ m,$search,);
                }
                else {
                    push @$results, $self->_file_info($file) if ($buffer =~ m,$search,i); 
                }                
            }
            else {
                while (read SOURCE, $buffer, $READ_SIZE) {
                    if ($self->{cgi}->{c_case}) { #None Case Sensitive 
                        if ($buffer =~ m,$search,) {
                            push @$results, $self->_file_info($file); 
                            last;                      
                        }
                    } 
                    else {
                        if ($buffer =~ m,$search,i) {
                            push @$results, $self->_file_info($file); 
                            last;                      
                        }
                    }
                }
            }
            close SOURCE;
        }
    }
    return $results;
}
END_OF_SUB

$COMPILE{cmd_replace} = __LINE__ . <<'END_OF_SUB';
sub cmd_replace {
#-----------------------------------------------------------------
# Search and replace 
#
    my $self = shift;
    $self->cmd_search(1);
}

sub _replace {
#-----------------------------------------------------------------------
# Search and replace contents
#
    my ($self,$files) = @_;

    my ($write,$results);
    my $search = $self->{cgi}->{txt_input};
    my $with   = $self->{cgi}->{txt_with};
    if ($self->{cgi}->{c_word}) {
        $search = " $search ";
        $with   = " $with ";
    }  
    if ($self->{cgi}->{c_regex}) { $search = quotemeta($search); }
    foreach (@$files) {   
        my $file = ($_->{name})? "$_->{parent}/$_->{name}" : $_->{parent};        
        if ((-T $file) and (-w $file)) {            
            next if (!open(SOURCE, "<$file"));
            my ($buffer, $found, $tmp);
            while (read SOURCE, $buffer, $READ_SIZE) {
                if ($self->{cgi}->{c_case}) { #None Case Sensitive 
                    if ($buffer =~ m,$search,) {
                        $found = 1;
                        last;                      
                    }
                } 
                else {
                    if ($buffer =~ m,$search,i) {
                        $found = 1;
                        last;                      
                    }
                }
            }
            close SOURCE;
            if ($found) {       
                my $tempfile = new GT::TempFile;
                if (!$self->{cfg}->{winnt}) {
                    $file  =~ m,^([\/\w.-]+)$,;
                    $file  = $1; #untainted  
                }

                $tmp = _fcopy($file, "$$tempfile.tmp");
                $tmp = _fcopy("$$tempfile.tmp", $file, $search, $with, $self->{cgi}->{c_case});                
                _fcopy("$$tempfile.tmp","$file.bak")    if ($self->{cgi}->{c_bak}); # create a .bak file
                push @$results, $self->_file_info($file) if ($tmp);
                
                $self->history("cmd_replace|$file|$search with $with") if ( $self->{cfg}->{multi} ); #save log inf 
            }            
        }        
    }   

    return $results;
}
END_OF_SUB

$COMPILE{cmd_command} = __LINE__ . <<'END_OF_SUB';
sub cmd_command {
#----------------------------------------------------------------
# execute a command
#
    my $self = shift;    
    $ENV{'PATH'}    = '/bin:/usr/bin:/usr/local/bin'; #for taint mode

    my $server_name = $ENV{'SERVER_NAME'};
    my $html_url    = $self->{cfg}->{html_root_url};
    my $url_opts    = $self->{url_opts}           || '';
    my $work_path   = $self->{work_path}          || '';
    my $working_dir = $self->{cgi}->{working_dir} || $self->_safe_dir();
    my $cmd         = $self->{cgi}->{txt_input}   || '';
    my $css_file    = $self->{in}->cookie('scheme') || 'fileman';
    my $prompt;
    my $run_file;
    my $full_path   = $self->{cfg}->{root_dir}.(($work_path)? "/$work_path" : '');     
    
    $self->history("cmd_command|$cmd") if ( $self->{cfg}->{multi} );#save log info
    
    if ($self->{cgi}->{c_edit}) {
        $run_file = $full_path.'/'.$self->{cgi}->{c_edit};     
        $cmd = $run_file.' '.$cmd;
    }
    print $self->{in}->header;   
    chdir ($working_dir);

# ping command
    if ($cmd =~ m,^\s*ping\s*, or $self->{cgi}->{long}) {
        $prompt = $self->{cfg}->{winnt} ? "$working_dir> " : "[". eval { getpwuid($<) } ."\@$server_name ".($working_dir || '/')."]";  
        my $command_time_out = $self->{cfg}->{command_time_out} || 60;
        my $pid; 
        my $oldfh;
        if(!$self->{cfg}->{winnt}) {
            $SIG{ALRM} = sub { die "timeout"};
            alarm($command_time_out);
        }
        print qq! 
            {cfg}->{html_root_url}/$css_file.css>
                
            
            
                        
            
            
            
            
            
            
            
            
            
            
            
            

            

            $prompt $cmd
            
        !;
        eval { 
                $pid   = open (TMP, "$cmd |");
                $oldfh = select(TMP); $| = 1; select($oldfh);
                while(){
                    s/(\n|\r\n)$//;
                    print GT::CGI->html_escape($_), "\n";
                }    
                close (TMP) or die $@;
        };
        if ($@) {
            if ($@ =~ /timeout/) {
                my $ret = kill ('INT', $pid);
                $ret ? print "Command timed out." : print "Command timed out. Unable to kill: $!";
            }
            else {
                die $@;
            }
        }
        print "
";
    }
    else {       
# Other command
        my ($output,$errors) = ('','');
        if ($cmd or $self->{cgi}->{runfile}) {
            my $tmp_output = new GT::TempFile; # create a result file
            my $tmp_errors = new GT::TempFile; # create a error file
            if ($self->{cfg}->{winnt}) { #for WinNT
                system ("$cmd 1> $$tmp_output 2> $$tmp_errors");
            }
            else {
                system ("$cmd 2> $$tmp_errors 1> $$tmp_output");
            }
            open (TMP, "< $$tmp_output") or return $self->cmd_main_display({reload => 1, status => $!});
            read (TMP, $output, -s TMP);
            close TMP;

            open (TMP, "< $$tmp_errors") or return $self->cmd_main_display({reload => 1, status => $!});
            read (TMP, $errors, -s TMP);
            close TMP;  
            if (($cmd =~ m/^\s*cd\s+(.+)/) and !$errors) {       
                ($self->{cfg}->{winnt} and $working_dir !~ m,^/,) and $working_dir = '/'.$working_dir;
                $working_dir = _command_show($working_dir,$cmd) || {};
                ($self->{cfg}->{winnt}) and $working_dir =~ s,/,,;
            }            
            $output   = $self->{in}->html_escape($output) if ($output);
            $errors ||= '';
        }
        my $action = ($cmd)? '' : "onload='top.js_cmd_command(1)'";
        $prompt    = $self->{cfg}->{winnt} ? "$working_dir> " : "[". eval { getpwuid($<) } ."\@$server_name ".($working_dir || '/')."]";        
        print qq! 
            
            
            

            $prompt $cmd
            
$output

            
$errors

            
            

            
            
            
            
            
            
            
            
            
                        
            
            
            

     !; 
    }          
}
END_OF_SUB

$COMPILE{cmd_upload} = __LINE__ . <<'END_OF_SUB';
sub cmd_upload {
# -----------------------------------------------------
# upload a files
#
    my ($self,$data) = @_;
    $ENV{'PATH'}  = ''; #for taint mode warning
    $data       ||= $self->{in}->param('txt_input');    
    my $work_path = $self->{work_path};
    my $path      = $self->{cfg}->{root_dir}.(($work_path)? "/$work_path" : '');

    if (!-w $path) { # Current directory does not writeable
        my $msg = sprintf($LANGUAGE{ERR_FILE_PEM},($work_path) ? $work_path : 'Root');
        ($self->{in}->param('txt_input'))? return $self->cmd_main_display({ reload => 1 , status => $msg}) : return (0, $msg);
    }

    my $free_space;
    if ($self->{cfg}->{allowed_space} > 0) {
        my $disk_space; 
        @$disk_space = $self->_checkspace($self->{cfg}->{root_dir});
        $free_space  = @$disk_space[0];        
    }  
    my $filename = $data;
    my $mode     = $self->{cgi}->{type}; 
    $filename    =~ s/.*?([^\\\/:]+)$/$1/;
    $filename    =~ s/[\[\]\s\$\#\%'"]/\_/g;


# Get the full file name and save the file.
    my ($bytesread, $buffer, $fullfile, $file_size);
    my $file    = $self->_safe_file ($filename, { fullfile => 1, exist => 1, write => 1});     
    ($file == -1) and return $self->cmd_main_display({ reload => 1, stastus => sprintf($LANGUAGE{ERR_INVALID},$filename)}); # not safe
    $fullfile   = $file->{file};
    if (!$self->{cfg}->{winnt}) {
        $fullfile  =~ m,^([\/\w.-]+)$,;
        $fullfile  = $1; #untainted  
    }
    if (!$self->{in}->param('txt_input')) { #multi upload
        ($file->{exist} and !$self->{cgi}->{overwrite})                    and return (0, sprintf($LANGUAGE{ERR_FILE_EXISTS},$filename));
        ($file->{exist} and !$file->{write} and $self->{cgi}->{overwrite}) and return (0, sprintf($LANGUAGE{ERR_FILE_PEM},$filename));
    }
    else {
        ($file->{exist} and !$self->{cgi}->{overwrite})                    and return $self->cmd_main_display({ reload => 1 , status =>sprintf($LANGUAGE{ERR_FILE_EXISTS},$filename)}); 
        ($file->{exist} and !$file->{write} and $self->{cgi}->{overwrite}) and return $self->cmd_main_display({ reload => 1 , status =>sprintf($LANGUAGE{ERR_FILE_PEM},$filename)});
    }

    $file_size  = 0;        
    open    (OUTFILE, ">$fullfile") ;
    binmode (OUTFILE); 
    while ($bytesread=read($data,$buffer,1024)) {
        if ($mode eq 'ascii') {
            $buffer =~ s,\r\n,\n,g; 
        }
        print OUTFILE $buffer;
        $file_size += 1024;
        if ($self->{cfg}->{allowed_space} > 0) {
            if (($file_size / 1024) > $free_space) {
                close OUTFILE;
                unlink ($fullfile);
                ($self->{in}->param('txt_input')) ? return $self->cmd_main_display({ reload => '1', status => $LANGUAGE{ERR_FREE_SPC}}) : return (0,$LANGUAGE{ERR_FREE_SPC});
            }
        }
    }

    close OUTFILE;
    if ($mode eq 'auto') {
        if (-T $fullfile) {
            open (FILE, "< $fullfile") or die sprintf($LANGUAGE{ERR_FILE_OPEN}, $fullfile, "$!");
            read (FILE, my $data, -s FILE);
            close FILE;

            $data =~ s,\r\n,\n,g;      
            open (FILE, "> $fullfile") or die sprintf($LANGUAGE{ERR_FILE_OPEN}, $fullfile, "$!");
            print FILE $data;
            close FILE;
            $mode = 'ascii/text';
        }
    }    
    my $status;
    if (-s $fullfile == 0) {
        unlink ($fullfile);
        $status = sprintf($LANGUAGE{ERR_UPLOAD}, $filename, "File is 0 bytes.");
    }
    else {
        $status = sprintf($LANGUAGE{UPLOAD_MODE},$filename,$mode);
    }
    ($self->{in}->param('txt_input')) and $self->cmd_main_display({ reload=>1 , status => $status});

    if (-e $fullfile || -s $fullfile != 0) {
        if ( $self->{cfg}->{multi} ) { #save log info
            my $from = $fullfile;
            $from =~ s/$path\///;
            $self->history("cmd_upload|$from|$path");
        }
        return (1, $status);
    }        
    else {
       return (0, $status);
    }       
}
END_OF_SUB


$COMPILE{cmd_mul_upload} = __LINE__ . <<'END_OF_SUB';
sub cmd_mul_upload {
# -----------------------------------------------------
# upload nulti files
#
    my $self  = shift;  
    my $count = 0;
    my $msg   = '';
    for my $i(1..10) {
        my $data = $self->{in}->param('file'.$i);
        next if (!$data);
        my ($result, $status) = $self->cmd_upload ($data);
        $result ? $count++ : ($msg .= $status . '
');
    }
    $self->{cgi}->{cmd_do} = 'cmd_upload';   
    $self->cmd_main_display ( { reload => 1 , status => $count ? sprintf($LANGUAGE{MSG_MULTI_UPLOAD},$count) : $msg } );
}
END_OF_SUB

$COMPILE{cmd_editor} = __LINE__ . <<'END_OF_SUB';
sub cmd_editor {
#-------------------------------------------------------------
#   Editor a text file
#
    my $self = shift;

    my $url_opts = $self->{url_opts}         || '';
    my $filename = $self->{cgi}->{filename}  || '';
    my $work_path   = $self->{work_path}     || '';
    my $root_path   = $self->{cfg}->{root_dir};
    my $data        = $self->{cgi}->{content}   || '';
    my $fullfile;

# Store number of rows and cols for TEXTAREA object into cookie
    if ($self->{cgi}->{resize}) {        
        my $rows = $self->{cgi}->{rows} || 20;
        my $cols = $self->{cgi}->{cols} || 100;
        $rows    = 20 if ($rows > 50);
        $cols    = 100 if ($cols > 200);        
        print $self->{in}->header (-cookie => [
                                               $self->{in}->cookie ( -name    => 'cols', -value   => $cols), 
                                               $self->{in}->cookie ( -name    => 'rows', -value   => $rows)
                                              ]);        
        my $size = 0;
        if ($filename) {
            my $file = $self->_safe_file($filename,{ size => 1});    
            $size = $file->{size};
        }
        my $status = sprintf($LANGUAGE{MSG_FILE_EDITING},'Editing ',$filename,$size,$filename);
        return $self->cmd_show({content  => $self->{in}->html_escape($data),
                                rows     => $rows,
                                cols     => $cols,
                                status   => $status,
                                use_html => 0,
                                old      => ($self->{cgi}->{filename})? 1 : 0});
    }

# Switch to HTML or TEXT layout
    elsif ($self->{cgi}->{switch_edit}) {       
        my $switch   = ($self->{cgi}->{use_html}) ? 0 : 1;       
        my $filename = $self->{cgi}->{filename};
        if ($filename) {
            my $file = $self->_safe_file($filename,{ write => 1, text => 1, fullfile => 1, size => 1, isfile => 1});
            ($file == -1)     and return $self->cmd_show({ msg => sprintf($LANGUAGE{ERR_INVALID},$filename)}); # not safe
            ($file->{isfile}) or  return $self->cmd_show({ msg => sprintf($LANGUAGE{ERR_NOT_FILE},$filename)}); # not a file
            my $status = sprintf($LANGUAGE{MSG_FILE_EDITING},'Editing ',$filename,$file->{size},$filename);
            return $self->cmd_show({ use_html => $switch,
                                     filename => ($filename =~ m,^/,)? '' : $filename,
                                     old      => ($filename =~ m,^/,)? 0 : 1, 
                                     use_html => $switch,
                                     writeable=> $file->{write}                                     
                                     });  
        }
        else {
             return $self->cmd_show({ use_html => $switch});
        }
    }

# Save the contents
    ($self->{cgi}->{save}) ? ($filename = $self->{cgi}->{filename}) 
                           : ($filename = $self->{cgi}->{filenew});

    my $old = $self->{cgi}->{fileold};
    my $msg = _valid_name_check($filename);
    ($msg) and return $self->cmd_show({msg => $msg, old => $old, use_html => $self->{cgi}->{use_html}});

    $self->{cgi}->{content} = $self->{in}->html_escape($data);

    my $file = $self->_safe_file($filename,{ fullfile => 1, exist => 1});     
    ($file == -1) and return $self->cmd_show({msg => sprintf($LANGUAGE{ERR_INVALID},$filename), old => $old}); # not safe
    $fullfile = $file->{file};
    
    if (($file->{exist}) and (!$old or $filename eq $self->{cgi}->{filenew})) { #file already exists                
        my $tempfile = new GT::TempFile;
        open (FILE, "> $$tempfile.tmp") or return $self->cmd_show({ msg => $LANGUAGE{ERR_TMP_FILE},
                                                                    old => $old});
        print FILE $data;
        close FILE;
        return $self->page('file_editor_confirm.html', { filename => $filename,                                                         
                                                         tmp_file => "$$tempfile.tmp"});
    }
    $self->editor_process($filename,$data);
}
END_OF_SUB

$COMPILE{editor_process} = __LINE__ . <<'END_OF_SUB';
sub editor_process {
#-------------------------------------------------------
#   Save the contents to a file
#   
    my ($self,$filename,$contents) = @_;

    if (!$filename) { 
        $filename      = $self->{cgi}->{filename};
        my $tmp_file ||= $self->{cgi}->{tmp_file};
        open (DATA,"<$tmp_file") or return $self->cmd_main_display({reload => 1, status => $LANGUAGE{ERR_TMP_FILE}});
        read (DATA, $contents, -s DATA);
        close DATA;
    }

    my $file = $self->_safe_file($filename,{ fullfile => 1});     
    my $old = $self->{cgi}->{fileold};    
 
    if ($file == -1) {       
        $self->{cgi}->{content} = $self->{in}->html_escape($contents);
        return $self->cmd_show({msg => sprintf($LANGUAGE{ERR_INVALID},$filename), old => $old}); # not safe  
    }
    my $fullfile = $file->{file};    

# Strip windows linefeeds.
    $contents =~ s,\r\n,\n,g;            

    open(FILE,">$fullfile") or return $self->cmd_show({ msg => sprintf($LANGUAGE{ERR_FILE_OPEN},$filename),
                                                        old => $old});
    print FILE $contents;
    close(FILE);

    if (-e $fullfile) {
        $self->history("cmd_edit|$fullfile") if ( $self->{cfg}->{multi} ); #save log info" 

        $self->{cgi}->{cmd_do} = 'cmd_command';
        my $status = (!$old) ? sprintf($LANGUAGE{MSG_FILE_CREATED},$filename) : sprintf($LANGUAGE{MSG_FILE_EDITED},$filename);        
        return $self->cmd_main_display({ reload => '1', status => $status});
    }     
    return $self->cmd_show({ msg => sprintf($LANGUAGE{ERR_FILE_SAVE},$filename)});    
}
END_OF_SUB

$COMPILE{cmd_makedir} = __LINE__ . <<'END_OF_SUB';
sub cmd_makedir {
#-----------------------------------------------
#   Make directory
#
    my $self = shift;    

# Get the full path.
    my $new = $self->{cgi}->{txt_input};
    my $msg = _valid_name_check($new);
    ($msg) and return $self->cmd_main_display({ reload => '1', status => $msg});

    my $work_path = $self->{work_path} || '';
    my $fulldir   = $self->_safe_dir($new, { exist => 1} );

    $fulldir == -1     and return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_INVALID}   ,$new)});
    $fulldir->{exist}  and return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_DIR_EXISTS},$new)});

    if ( mkdir ($fulldir->{fulldir}, 0755) ) {
        $self->history("cmd_makedir|$fulldir->{fulldir}") if ( $self->{cfg}->{multi} ); #save log info
        return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{MSG_DIR_CREATED}, $new)});
    }    
    
    return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_DIR_PEM},($new =~ m,^/,) ? $new : ($work_path || 'Root'))}); 
}
END_OF_SUB

$COMPILE{cmd_preferences} = __LINE__ . <<'END_OF_SUB';
sub cmd_preferences {
#---------------------------------------------------
#   Save options of system
#
    my $self = shift;
    ($self->{cgi}->{save}) or return $self->cmd_main_display();

    my $def_sort        = $self->{cgi}->{def_sort}          || 'Name';
    my $def_working_dir = $self->{cgi}->{def_working_dir}   || '/';
    my $def_passwd_dir  = $self->{cgi}->{def_passwd_dir};
    my $def_files_page  = $self->{cgi}->{def_files_page}    || (($self->{cgi}->{showall})? 'all': 25);
    my $def_pages_screen= $self->{cgi}->{def_pages_screen}  || (($self->{cgi}->{showall})? 'all': 20);
    my $readme_position = $self->{cgi}->{readme_position};
    my $hidden_file     = $self->{cgi}->{hidden_file};
    my $editor_mode     = $self->{cgi}->{editor_mode}       || '0';
    my $scheme          = $self->{cgi}->{scheme}            || 'fileman';
    my $font            = $self->{cgi}->{font}              || "";

    ($font =~ /^$/) or $font = "";
    $def_files_page     = 25 if ($def_files_page    > 100);
    $def_pages_screen   = 20 if ($def_pages_screen  > 50);  
    $def_working_dir    =~ s/(\.\.)+//g;
    $def_passwd_dir     =~ s/(\.\.)+//g;
    $def_passwd_dir   = "$self->{cfg}->{root_dir}/$def_passwd_dir" if ($def_passwd_dir and !$self->{cfg}->{passwd_dir_level});
    $def_passwd_dir ||= '0';

    if ($def_passwd_dir and (!-e $def_passwd_dir or !-w _)) {
        $self->{cgi}->{page} = 'preferences.html';
        (-e _) or return $self->cmd_show( {msg => sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS},$def_passwd_dir)} );
        (-w _) or return $self->cmd_show( {msg => sprintf($LANGUAGE{ERR_DIR_PEM},$def_passwd_dir)} );
    }
    print $self->{in}->header (-cookie => [                                           
                                           $self->{in}->cookie ( -name    => 'def_sort',        -value   => $def_sort,          -expires => '+5y'),
                                           $self->{in}->cookie ( -name    => 'def_passwd_dir',  -value   => $def_passwd_dir,    -expires => '+5y'),
                                           $self->{in}->cookie ( -name    => 'def_working_dir', -value   => $def_working_dir,   -expires => '+5y'),
                                           $self->{in}->cookie ( -name    => 'def_files_page',  -value   => $def_files_page,    -expires => '+5y'),
                                           $self->{in}->cookie ( -name    => 'def_pages_screen',-value   => $def_pages_screen,  -expires => '+5y'),
                                           $self->{in}->cookie ( -name    => 'readme_position', -value   => $readme_position,   -expires => '+5y'),
                                           $self->{in}->cookie ( -name    => 'hidden_file'    , -value   => $hidden_file,       -expires => '+5y'),
                                           $self->{in}->cookie ( -name    => 'scheme'        ,  -value   => $scheme,            -expires => '+5y'),
                                           $self->{in}->cookie ( -name    => 'font'          ,  -value   => $font,              -expires => '+5y'),
                                           $self->{in}->cookie ( -name    => 'editor_mode'   ,  -value   => $editor_mode,       -expires => '+5y'),
                                          ]);
    $self->{cgi}->{cmd_do} = 'cmd_command';
    return $self->cmd_main_display( {reload => 1, status => $LANGUAGE{MSG_PREFERENCES}, re_scheme => 1});
}
END_OF_SUB

$COMPILE{user_form} = __LINE__ . <<'END_OF_SUB';
sub user_form {
#---------------------------------------------------
#   Save options of system
#
    my ($self,$msg) = @_;
    ($self->{cfg}->{multi} or $self->{cfg}->{single}) or die $LANGUAGE{ERR_VERSION};
    $self->page('user_form.html', { msg => $msg});
}
END_OF_SUB

$COMPILE{cmd_admin} = __LINE__ . <<'END_OF_SUB';
sub cmd_admin {
#---------------------------------------------------
#   Save  user password
#
    my $self = shift;
    ($self->{cfg}->{multi} or $self->{cfg}->{single}) or die $LANGUAGE{ERR_VERSION};
    ($self->{cfg}->{single}) and return $self->pwd_single();

    my $username = $self->{cgi}->{Username};
    my $old_pass = $self->{cgi}->{Old_Password};
    my $new_pass = $self->{cgi}->{New_Password};
    my $db_name  = $self->{cfg}->{db_name};
    
    ($old_pass)                            or return $self->user_form($LANGUAGE{ERR_OLD_PASSWORD});
    ($new_pass and length($new_pass) >= 3) or return $self->user_form($LANGUAGE{ERR_NEW_PASSWORD});

    open (DATA,"<$self->{cfg}->{priv_path}/$db_name") or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_FILE_OPEN},$db_name, "$!")},1);
        flock(DATA, 1);
        my @lines = ;
    close DATA;    
    my $found; 

# check username and password
    LINE: foreach (@lines) {
        if ($_ =~ /^$/) { next LINE; }
        if ($_ =~ /^#/) { next LINE; }
        chomp ($_); 
        $_ =~ s/\r//g;  # Remove Windows linefeed character.
        my @record = split (/\Q|\E/o, $_);        
        if (($record[1] ne $username) or ($record[2] ne crypt($old_pass,$old_pass))) { next LINE;}
        $found = 1;
        last;
    }
    ($found) or return $self->user_form($LANGUAGE{ERR_OLD_PASSWORD});

# Save user information
    my $rows;
    LINE: foreach (@lines) {
        if ($_ =~ /^$/) { next LINE; }
        if ($_ =~ /^#/) { next LINE; }
        chomp ($_); 
        $_ =~ s/\r//g;  # Remove Windows linefeed character.
        my @record = split (/\Q|\E/o, $_);        
        if ($username eq $record[1]) { # replace user information
            $record[2] = crypt($new_pass,$new_pass);
            $rows .= join("|",@record);
        }
        else {
            $rows .= $_;
        }
        $rows .= "\n";
    }
    open (NEW,">$self->{cfg}->{priv_path}/$db_name") or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_FILE_OPEN},$db_name, "$!")},1);
        flock(NEW, 2);
        print NEW $rows;
    close NEW;
    return $self->cmd_main_display({reload => 1, status => $LANGUAGE{MSG_PWD_CHANGED}},1);
}
END_OF_SUB

sub pwd_single () {
#------------------------------------------------------
# Change password in single version
#
    my $self = shift;
    ($self->{cfg}->{single}) or die $LANGUAGE{ERR_VERSION};
    my $fn = "$self->{cfg}->{root_path}/ConfigData.pm"; 
    (-e $fn) or return $self->user_form(sprintf($LANGUAGE{ERR_OPEN_FILE},'ConfigData.pm',$!));
    (-w _)   or return $self->user_form(sprintf($LANGUAGE{ERR_WRITEABLE},'ConfigData.pm',$!));

    my $old = $self->{cgi}->{Old_Password};
    my $new = $self->{cgi}->{New_Password};
    ($old)                              or return $self->user_form($LANGUAGE{ERR_OLD_PASSWORD});
    ($new and length($new) >= 3)        or return $self->user_form($LANGUAGE{ERR_NEW_PASSWORD});
    ($old eq $self->{cfg}->{password})  or return $self->user_form($LANGUAGE{ERR_OLD_PASSWORD});

    $self->{cfg}->{password} = $new;
    my $time = localtime;
    open (FH, "> $fn") or return $self->user_form(sprintf($LANGUAGE{ERR_OPEN_FILE},'ConfigData.pm',$!));
    print FH <dump ( var => '', data => $self->{cfg} );
    close FH;
    print $self->{in}->header (-cookie => [ $self->{in}->cookie ( -name    => 'password', -value   => crypt($self->{cfg}->{password}, $self->{cfg}->{username}), -expires => '') ]);
    return $self->cmd_main_display({reload => 1, status => $LANGUAGE{MSG_PWD_CHANGED}},1);
}

$COMPILE{log_off} = __LINE__ . <<'END_OF_SUB';
sub log_off {
#---------------------------------------------------
#   Log off
#
    my $self = shift;
    print $self->{in}->header ( -cookie => [ $self->{in}->cookie ( -name => 'username', -value => '', -expires => '' ),
                                             $self->{in}->cookie ( -name => 'password', -value => '', -expires => '' ) ]);
    return $self->page('login_form.html', { msg => $LANGUAGE{MSG_LOG_OFF}});
}
END_OF_SUB

$COMPILE{cmd_view} = __LINE__ . <<'END_OF_SUB';
sub cmd_view {
#---------------------------------------------------
#   View a file
#
    my ($self,$filename) = @_;
    $filename ||= $self->{cgi}->{c_edit};
    my $file = $self->_safe_file($filename,{ write => 1, text => 1, fullfile => 1, size => 1});
    ($file == -1) and return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_INVALID},$filename)}); # not safe

    my $url_opts  = $self->{url_opts}  || '';
    my $work_path = $self->{work_path} || '';
    my $fullfile  = $file->{file};     
# Image file
    my ($ext)    = $fullfile =~ /\.([^.]+)$/;
    my $img_type = "bmp gif jpg jpeg tif tiff";    
    my $status = sprintf($LANGUAGE{MSG_FILE_EDITING},'View ',$filename,-s $fullfile,$filename);

    return $self->page('view_image.html',{ filename => $filename,
                                           work_path=> $work_path,
                                           status   => $status})
                                           if (($img_type =~ m,$ext,) and $ext);   
    $self->_view_file($filename);

}
END_OF_SUB

$COMPILE{cmd_edit} = __LINE__ . <<'END_OF_SUB';
sub cmd_edit {
#-------------------------------------------------------------
#   Print the content of a file
#
    my ($self,$filename,$use_html) = @_;

    $filename ||= $self->{cgi}->{c_edit};    
    my $file = $self->_safe_file($filename,{ write => 1, text => 1, fullfile => 1, size => 1, isfile => 1});
    ($file == -1)     and return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_INVALID},$filename)},1); # not safe
    ($file->{isfile}) or  return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_NOT_FILE},$filename)},1); # not a file

    my $url_opts  = $self->{url_opts}  || '';
    my $work_path = $self->{work_path} || '';
    my $fullfile  = $file->{file};     
    my ($ext)     = $fullfile =~ /\.([^.]+)$/;
    my $browser;    
    $browser = 1 if ($ENV{HTTP_USER_AGENT} =~ m,MSIE 5, or $ENV{HTTP_USER_AGENT} =~ m,MSIE 6,);
    if ($file->{text} and $ext ne 'pdf') { # Text file
        open (DATA,"<$fullfile") or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_FILE_OPEN},$filename, "$!")},1);
        read (DATA, my $content, -s DATA);
        close DATA;
        if ( $browser and (($ext eq 'html') or ($ext eq 'htm')) and !defined $use_html and !$self->{in}->cookie('editor_mode') ) { #should show HTML mode
            $use_html = 1; 
            $content  =~ s/
{in}->html_escape($content);   
        my $status = sprintf($LANGUAGE{MSG_FILE_EDITING},'Editing ',$filename,$file->{size},$filename);
        $self->cmd_show({content  => $content,
                         filename => ($filename =~ m,^/,)? '' : $filename,
                         status   => $status,
                         old      => ($filename =~ m,^/,)? 0 : 1, 
                         use_html => $use_html,
                         writeable=> $file->{write}});        
        return;
    }
# Image file
    my $img_type = "bmp gif jpg jpeg tif tiff";    
    my $status = sprintf($LANGUAGE{MSG_FILE_EDITING},'View ',$filename,-s $fullfile,$filename);
    return $self->page('view_image.html',{ filename => $filename,
                                           work_path=> $work_path,
                                           status   => $status})
                                           if ($img_type =~ m,$ext,);   
    
    my $doc = "doc xls pdf DOC XLS PDF";
    return $self->_view_file($filename)       if ($doc =~ m,$ext,); # .doc, .xls, .pdf file
    return $self->_tar_information($filename) if ($ext eq 'tar'); # .tar file
    return $self->_tar_information($filename) if ($ext eq 'gz' and $GT::FileMan::HAVE_GZIP); # .gz file    
    return $self->_send_to_browser($fullfile); # Download if it is an unknow file
}
END_OF_SUB

$COMPILE{cmd_print_img} = __LINE__ . <<'END_OF_SUB';
sub cmd_print_img {
#----------------------------------------------------
# print image file
#
    my $self = shift;
    
    my $filename  = $self->{cgi}->{filename};
    $self->_view_file($filename);   
}
END_OF_SUB

$COMPILE{cmd_download} = __LINE__ . <<'END_OF_SUB';
sub cmd_download {
#----------------------------------------------------------------
#   download  a file
#
    my $self = shift;
   
    my $filename = $self->{in}->param('c_edit');
    my $file     = $self->_safe_file($filename,{ fullfile => 1});     
    ($file == -1) and return $self->cmd_main_display({ reload => 1, stastus => sprintf($LANGUAGE{ERR_INVALID},$filename)}); # not safe

    my $full_name   = $file->{file};
    $self->{cgi}->{cmd_do} = 'cmd_command';
    return $self->cmd_main_display({reload => 1, status => $LANGUAGE{ERR_DOWNLOAD}}) if (-d $full_name);
    $self->_send_to_browser($full_name);
}
END_OF_SUB

sub _send_to_browser {
#----------------------------------------------------------------
# send the contents of a file to browser for downloading
#   
    my $self = shift; 
    my $send_file = shift;
    if(open(SENDFILE, $send_file)) {
        $self->history("cmd_download|$send_file") if ( $self->{cfg}->{multi} ); #save log file

        my $file_size = -s $send_file;
        my ($file)    = $send_file =~ m,/([^/]+)$,;
        print $self->{in}->header(
                                    '-type'                      => 'application/download',
                                    '-Content-Length'            => $file_size,
                                    '-Content-Transfer-Encoding' => 'binary',
                                    '-Content-Disposition'       => \"attachment; filename=$file"
                                 );     
        ($self->{cfg}->{winnt}) and binmode STDOUT;                               
        binmode SENDFILE;
        my $buffer;
        print $buffer while (read(SENDFILE, $buffer, $READ_SIZE));
        close SENDFILE;
    }           
    else { # failed to open file
       $send_file =~ s,$self->{cfg}->{root_path},,;
       die sprintf($LANGUAGE{ERR_FILE_OPEN}, $send_file, "$!");
    }               
}

$COMPILE{cmd_copy} = __LINE__ . <<'END_OF_SUB';
sub cmd_copy {
#---------------------------------------------------
#   Copy and move files and directories
#
    my $self = shift;    
    
# Check diskspace, permission, total size will copy 
    my $status = $self->_copy_prepare();    
    ($status) and return $self->cmd_main_display({reload => 1, status => $status});  
    $COPIED = 0;

    $self->page('progress_bar.html');
    $self->cmd_copy_process();
}
END_OF_SUB

$COMPILE{cmd_copy_process} = __LINE__ . <<'END_OF_SUB';
sub cmd_copy_process {
#------------------------------------------------------------------------------
#   Confirm when exits files or directory
#
    my ($self,$action) = @_;

    $action ||= $self->{cgi}->{action};
    if ($self->{cgi}->{cancel}) { #copy cancel
        $self->{cgi}->{cmd_do} = 'cmd_copy';
        return $self->cmd_main_display( {reload => 1, status => sprintf($LANGUAGE{MSG_COPY_CANCEL},($action)? 'move':'copy')}); 
    }
#confirm variables 
    my $over      = $self->{cgi}->{over};
    my $skip      = $self->{cgi}->{skip};
    my $all       = $self->{cgi}->{all};
    my $file_cur  = $self->{cgi}->{file_cur} || '';
    my $total_size= $self->{cgi}->{total_size};    
#root, work path variable
    my $root_path = $self->{cfg}->{root_dir};
    my $work_path = $self->{work_path};      
    my $from_path = $self->_safe_dir();            
#input variables
    my $input     = $self->{cgi}->{txt_input};
    my $fulldir   = $self->_safe_dir($input,{ exist => 1, write => 1});    
    ($fulldir == -1) and return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID}, $input) }); # not safe
    
    my $to_path     = $fulldir->{fulldir};
    my $files       = [$self->{in}->param('c_edit')];            
    my $file_copied = $self->{cgi}->{copied} || 0;
    my $not_ok      = 0;
    my $history     = ($action) ? 'cmd_move|' : 'cmd_copy|';
    
    for my $ii  ( 0.. $#$files) {   
        my $file = @$files[$ii];
        if ($file eq $file_cur and $skip) {
            my $skiped   = _space_used("$from_path/$file");
            my $progress = _load_progress_bar($COPIED,$skiped,$total_size);
            $self->page('copy_status.html', { msg     => "Skiped $file", 
                                              pxs     => $progress->{pxs},
                                              percent => $progress->{percent}});  
            next;
        }
        if ( (-e "$to_path/$file") and ($file ne $file_cur) and (!$all) ) {
            my $results;
            for my $jj ( $ii.. $#$files) {
                push @$results, {name => @$files[$jj]};
            }
            return $self->page('progress_bar.html',{confirm     => 1,
                                                    from        => "$work_path/$file",
                                                    to          => "$input/$file",
                                                    results     => $results,
                                                    file_cur    => $file,
                                                    txt_input   => $input,
                                                    action      => $action,
                                                    copied      => $file_copied});            
        }
        my $data;
        my $fulldir = $self->_safe_dir($file);
        next if ($fulldir == -1);
        $data = subdir(0, 0, $fulldir->{fulldir});

        if ($self->{cgi}->{search}) {
            my $dir     = $fulldir->{fulldir};
            my ($file)  =  $dir =~ /\/([^\/]+)$/;
            $dir =~ s/\/$file//;                
            $self->_copy_wanted($data, $from_path, $to_path, $dir);
            $history .= "$from_path:";
        }
        else {
            $self->_copy_wanted($data,"$from_path/$file",($self->{cgi}->{cp_type}) ? $to_path : "$to_path/$file");
            $history .= "$from_path/$file:";
        }
        $file_copied++;                         
        if ($action) { #remove files and directories
            $not_ok += $self->_move_wanted($data); 
        }        
    }  
    chop $history;
    $history .= "|$to_path";
    $self->history($history) if ( $self->{cfg}->{multi} );#save log info
    
    $self->{cgi}->{cmd_do} = ($action)? 'cmd_move' : 'cmd_copy';    
    my $status = sprintf($LANGUAGE{MSG_COPIED}, $file_copied, ($action) ? 'moved' : 'copied');
    $status    = sprintf($LANGUAGE{MSG_MOVED}, $file_copied, ($action) ?  'moved' : 'copied', $not_ok) if ( $not_ok );
    $self->cmd_main_display({ reload => 1, status => $status, search => 0});
}
END_OF_SUB

sub _copy_prepare {
#------------------------------------------------------
#   Check diskspace, writeable ... before save
#
    my ($self,$action) = @_;    
    $self->{cgi}->{total_size}  = 0;    
    $self->{cgi}->{copied}      = 0;
    my $root_path = $self->{cfg}->{root_dir};
    my $work_path = $self->{work_path};  
    my $from_path = $self->_safe_dir();
    my $files     = [$self->{in}->param('c_edit')];
#input variables
    my $input   = $self->{cgi}->{txt_input};
    my $fulldir = $self->_safe_dir($input, { exist => 1, write => 1});    
    ($fulldir == -1) and return sprintf($LANGUAGE{ERR_INVALID},$input); # not safe

    my $to_path = $fulldir->{fulldir};

# Create a file if selected a file that it does not exists.
    if ($#$files == 0) {
        if (!$fulldir->{exist}) {
            my $obj = "$from_path/@$files[0]";
            if (-l $obj) { # links
                local($SIG{__DIE__}, $@);
                eval {
                    my $link = readlink($obj) or die $!;
                    link($link, $to_path) or return $self->cmd_main_display({ reload => 1, status => $!});
                };
            } elsif (-d $obj) { # Directories            
                mkdir($to_path, 0775) or return $LANGUAGE{ERR_DIR_PERM};
                $self->{cgi}->{cp_type} = 1;
            }
            else { # Files
                open(TARGET, ">$to_path") or return $LANGUAGE{ERR_DIR_PERM};
                open(SOURCE, "<$obj") or return printf($LANGUAGE{ERR_FILE_OPEN},@$files[0]);
                binmode SOURCE;
                binmode TARGET;
                my $buffer;
                while (read SOURCE, $buffer, 1024) { print TARGET $buffer; }
                close SOURCE;
                close TARGET;
                _init_chmod($obj,$to_path);
                unlink($obj) if ($action);
                return sprintf($LANGUAGE{MSG_COPIED}, 1, ($action) ? 'moved' : 'copied'); 
            }
        }
    }
    else {        
        $fulldir->{exist}  or  return sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS},$input); # not exist
        $fulldir->{write}  or  return sprintf($LANGUAGE{ERR_DIR_PEM},($input eq '/')? 'Root' : $input); #permission   
    }

# Calculate total size of the copy file. 
    my $total_size = 0;    
    foreach my $file (@$files) {        
        $total_size += _space_used("$from_path/$file");
    }   
    $self->{cgi}->{total_size} = $total_size;   

# Check free space.
    if ($self->{cfg}->{allowed_space} > 0) {
        my @disk_space = $self->_checkspace($to_path);
        my $free_space = $disk_space[0];   
        ($total_size > $free_space * 1024 ) and return sprintf($LANGUAGE{ERR_DISK_SPACE}, $free_space);
    }
}

sub _copy_wanted {
#------------------------------------------------------------
# Copy files and directories
#
    my ($self, $data, $from, $to, $replace) = @_;
    my $total_size = $self->{cgi}->{total_size};
    my ($msg,$s,$progress);

    foreach (@$data) {        
        my $target = $_;
        ($self->{cgi}->{search}) ? ($target =~ s,$replace,$to,) : ($target =~ s,$from,$to,);
        $s = (-s $_);           
        $COPIED += $s;
        if (!$self->{cfg}->{winnt}) {            
            $target  =~ m,^([\/\w.-]+)$,;
            $target  = $1; #untainted                    
        }

        if (-l $_) { # links            
            local($SIG{__DIE__}, $@);
            eval {
                my $link = readlink($_) or die $!;
                link($link, $target) ? ($msg = 'ok') : ($msg ='not ok');
            };
        } 
        elsif (-d $_) { # Directories            
            mkdir("$target", 0775) ? ($msg = "ok") : ($msg = "not ok");  
            _init_chmod($_, $target) if ($msg eq 'ok');
        }
        else { # Files
            next if (!$target);
            if(!open(SOURCE, "<$_")) {
                $progress = _load_progress_bar($COPIED, $s, $total_size);
                $self->page('copy_status.html',{ msg     => "$_...$!", 
                                                 pxs     => $progress->{pxs}, 
                                                 percent => $progress->{percent}}); 
                next;
            }                

            if (!open(TARGET, ">$target")) {
                $progress = _load_progress_bar($COPIED,$s,$total_size);
                $self->page('copy_status.html',{ msg     => "$_...$!", 
                                                 pxs     => $progress->{pxs}, 
                                                 percent => $progress->{percent}}); 
                next;
            }
         
            binmode SOURCE;
            binmode TARGET;
            my $buffer;
            while (read SOURCE, $buffer, 1024) { print TARGET $buffer; }
            close SOURCE;
            close TARGET;
            _init_chmod($_,$target);              
        }       
        $progress = _load_progress_bar($COPIED,$s,$total_size);
        $self->page('copy_status.html',{ msg     => "$_...ok", 
                                         pxs     => $progress->{pxs}, 
                                         percent => $progress->{percent}}); 
    }
}

$COMPILE{cmd_delete} = __LINE__ . <<'END_OF_SUB';
sub cmd_delete {
# --------------------------------------------------------
# Delete files or directories
#
    my $self = shift;
    my ($files,$notdeleted);

#List files and dirs need to remove
    @$files        = $self->{in}->param('c_edit');
    my $count_file = 0;
    my $count_dir  = 0;
    my $history    = '';
    foreach  ( @$files ) {
        my $file = $self->_safe_file($_, { fullfile => 1 });
        if ( $file == -1 ) { 
            $self->{cgi}->{cmd_do} = "cmd_command" ;
            return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_INVALID},$_) }); # not safe
        }
        my $full_name = $file->{file};
        if ( -d $full_name && !-l $full_name ) {
            if ( rmdir($full_name) ) {
                $count_dir++;
            }
            else {
                push @$notdeleted,$_;
            }
        }
        else {
            if ( unlink($full_name) ) {
               $count_file++;
               $history .= "$full_name:";
            }                           
        }
    }
    if ( $history ) {
        chop $history;
        $self->history("cmd_delete|$history") if ( $self->{cfg}->{multi} ); #save log info        
    }    

    $self->list_files();
    my $status = ( $count_file > 0 or $count_dir > 0 ) ? sprintf($LANGUAGE{MSG_DEL_SUCC}, $count_file, $count_dir) : $LANGUAGE{ERR_DEL};
    if ($notdeleted) {

# Return list file for loop if recursive diectory
        my $list_files;
        foreach  ( @$notdeleted ) {
            push @$list_files, { name => $_ };
        }
        $self->{cgi}->{cmd_do} = "cmd_del_confirm";
        return $self->page('confirm_delete.html', { reload => 1, list_files => $list_files, file_cur => @$files[0], status => $status });
    }
    else {
        $self->{cgi}->{cmd_do} = "cmd_command";
        $self->cmd_main_display( { reload => 1, status => $status });
    }
}
END_OF_SUB

sub del_recursively {
# --------------------------------------------------------
# List subdir of a directory
#
    my ($self, $directory) = @_;
    my $error = 0;
    my $list  = subdir(0,0,$directory);
    foreach my $file (reverse @$list) {
        if ( !$self->{cfg}->{winnt} ) {   #untaint if unix
            $file =~ m,^([/\w.-]+)$,;
            $file = $1;
        }
        if (-d $file) {
            rmdir($file) or $error = 1;
        }
        else {
            unlink($file) or $error = 1;
        }
    }

    return $error;
}

$COMPILE{cmd_del_confirm} = __LINE__ . <<'END_OF_SUB';
sub cmd_del_confirm {
# --------------------------------------------------------
# confirm before delete a directory have subdir
#
    my $self = shift;
    my $full_path = $self->_safe_dir(); 

    my ($files, $history);
    if ( $self->{in}->param('c_edit') ) {
        @$files = $self->{in}->param('c_edit');

#Confirm remove all recursive directorys
        if ( $self->{cgi}->{all} ) {          
            foreach  ( @$files ) {
                my $file = $self->_safe_file($_,{fullfile => 1});
                ($file == -1) and return $self->cmd_main_display({ reload => 1, stastus => sprintf($LANGUAGE{ERR_INVALID},$_)}); # not safe
                my $full_name = $file->{file};
                $self->del_recursively($full_name);
                $history .= "$full_name:";
            }
            if ( $history and $self->{cfg}->{multi} ) {
                chop $history;
                $self->history("cmd_delete|$history"); #save log info
            }
            $self->{cgi}->{cmd_do} = "cmd_command";
            return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_DEL_ALL}}); 
        }

#Remove current recursive directory
        elsif ( $self->{cgi}->{over} ) {
            my $file_cur  = shift(@$files);
            my $file = $self->_safe_file($file_cur,{ fullfile => 1 });
            ( $file == -1 ) and return $self->cmd_main_display({ reload => 1, stastus => sprintf($LANGUAGE{ERR_INVALID}, $file_cur) }); # not safe
            
            my $full_name = $file->{file};
            $self->del_recursively($full_name);
            $history .= "$full_name:";
            
            my $list_files;
            foreach  ( @$files ) {
                push @$list_files, { name => $_ };
            }
            if ( $#$files >= 0 ) {
                $self->{cgi}->{cmd_do} = "cmd_del_confirm";
                my $status = sprintf($LANGUAGE{MSG_DEL_CURR},$self->{cgi}->{file_cur});
                return $self->page('confirm_delete.html',{ reload => 1, list_files => $list_files, file_cur => @$files[0] }, status => $status);
            }
        }
#Skip remmoving current dir
        elsif ( $self->{cgi}->{skip} ) {
            shift(@$files);
            my $list_files;
            foreach  (@$files) {
                push @$list_files, { name => $_ };
            }
            if ($#$files >= 0) {
                $self->{cgi}->{cmd_do} = "cmd_del_confirm";
                my $status = sprintf($LANGUAGE{MSG_DEL_SKIP}, $self->{cgi}->{file_cur});
                return $self->page('confirm_delete.html',{ reload => 1, list_files => $list_files, file_cur => @$files[0]}, status => $status);
            }
        }

#Cancel delete recursive
        elsif ( $self->{cgi}->{cancel} ) {
            $self->{cgi}->{cmd_do} = "cmd_command";
            return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_DEL_CANC} }); 
        }
    }
    if ( $history and $self->{cfg}->{multi} ) {
        chop $history;
        $self->history("cmd_delete|$history"); #save log info
    } 
    $self->{cgi}->{cmd_do} = "cmd_command";
    return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_DEL_ALL_SUCC} }); 
}
END_OF_SUB


$COMPILE{cmd_move} = __LINE__ . <<'END_OF_SUB';
sub cmd_move {
#--------------------------------------------------------------------------------
#   Move files and directories function
#
    my $self = shift;
    my $status = $self->_copy_prepare(1);
    ($status) and return $self->cmd_main_display({reload => 1, status => $status});    
    $COPIED = 0;
    $self->page('progress_bar.html');
    $self->cmd_copy_process(1);      
}
END_OF_SUB

sub _move_wanted {
#--------------------------------------------------------------------------------
#   Move files and directories
#
    my ($self,$data) = @_;
    my $count = 0;
    foreach my $ii (0 .. $#$data) {
        my $file = @$data[$#$data - $ii];
        if (!$self->{cfg}->{winnt}) {
            $file =~ m,^([/\w.-]+)$,;
            $file = $1;
        }
        if (-d $file) {
            if (!rmdir($file)) {
                $count++;
                next;
            }
        }
        else {
           unlink($file);
        }
    }
    return $count;
}

$COMPILE{cmd_chmod} = __LINE__ . <<'END_OF_SUB';
sub cmd_chmod {
# --------------------------------------------------------
# Changes the permission attributes of a file

    my $self = shift;
    my ($full_filename,$octal_perm); 
    my $newperm   = $self->{cgi}->{txt_input};    
    my $count     = 0;
    my $full_path = $self->_safe_dir();
    my $files     = $self->{cgi}->{c_edit};
    my $history   = "cmd_chmod|";
    my $filesnot;
#if only one file
    (ref $files eq 'ARRAY') or $files = [$files];
    foreach  (@$files) {
        my $file = $self->_safe_file($_, { fullfile => 1 });
        ($file == -1) and return $self->cmd_main_display({ reload => 1, stastus => sprintf($LANGUAGE{ERR_INVALID},$_)}); # not safe
        
        $full_filename = $file->{file};
        $octal_perm    = oct($newperm);   # Permissions have to be in octal.
        $history .= "$full_filename:";
        chmod ($octal_perm, $full_filename) and $count++;
    }
    chop $history;
    
    $self->history($history) if ( $self->{cfg}->{multi} );#save log info
    
    my $status = ( $count )  ? sprintf($LANGUAGE{MSG_CHMOD_CHANGED}, $count) : $LANGUAGE{ERR_CHMOD};
    $self->cmd_main_display({ reload => 1,
                              status => $status});   
}
END_OF_SUB


$COMPILE{cmd_tail} = __LINE__ . <<'END_OF_SUB';
sub cmd_tail {
#-----------------------------------------------------
#   tail command
#   
    my $self = shift;
    my $filename  = $self->{cgi}->{c_edit};
    my $url_opts  = $self->{url_opts}  || '';
    my $work_path = $self->{work_path} || '';
    my $file      = $self->_safe_file($filename,{fullfile => 1, exist => 1, isfile => 1, size => 1});
    ($file == -1) and return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_INVALID},$filename)}); #not safe

    my $fullfile  = $file->{file};
    my $retime    = $self->{cgi}->{retime};
    my $contents  = ''; 

    ($file->{exist})  or return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_NOT_EXISTS},$filename)});
    ($file->{isfile}) or return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_NOT_ISFILE},$filename)});
    my $lines = $self->{cgi}->{txt_input} || 10;
 
    my $follow;    
    @ARGV = grep { if ($_ eq "-f") { $follow++; 0 } else { 1 } } @ARGV;
    
    open FILE, "<$fullfile" or return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_OPEN},$filename)});
    my $file_size = $file->{size};
    return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_EMPTY}, $filename)}) unless $file_size;

    print $self->{in}->header;
    if ($retime) {
        print qq!
                
             !;
    }

    my $css_file    = $self->{in}->cookie('scheme') || 'fileman';
    print qq!         
        {cfg}->{html_root_url}/$css_file.css>
        
        
        
        
        
        
        
        
        
        
        
        
        
           
        
         
        
!;
    my $read_size   = 4096;
    my $to_read     = ($file_size > $read_size) ? $read_size : $file_size;
    my $buffer;
    seek FILE, -$to_read, 2;
    read FILE, $buffer, $to_read;
    my $read        = $to_read;
    my $need_lines  = $lines - 1;    
    while () {
        if ($buffer =~ /\n(.*(?:\n.*){$need_lines}\n?$)/) {
            print $self->{in}->html_escape($1);
            last;
        }
        $to_read = ($file_size - $read > $read_size) ? $read_size : $file_size - $read;
        unless ($to_read == 0) {
            print $self->{in}->html_escape($buffer);
            last;
        }
        seek FILE, -($to_read + $read), 2;
        $read += $to_read;
        my $new_buffer;
        my $bytes_read = read FILE, $new_buffer, $to_read;
        if ($bytes_read == 0) {
            print $self->{in}->html_escape($buffer);
            last;
        }
        $buffer = $new_buffer . $buffer;
    }

    my $cnt = 0;
    if ($follow) {
        seek FILE, 0, 2; # Seek to the end of the file
        while () {
            select undef, undef, undef, 1;
            seek FILE, 0, 1 or last; # Reset eof(FILE)
            print while ;
            seek FILE, 0, 2;
            last if ($cnt++ > 60); # Only run for one min max.
        }
    }
    print "
";
}
END_OF_SUB


$COMPILE{cmd_perl} = __LINE__ . <<'END_OF_SUB';
sub cmd_perl {
#----------------------------------------------------------------
# check perl syntax
#   
    my $self = shift;
    $ENV{'PATH'}    = '/bin:/usr/bin:/usr/local/bin'; #for taint mode

    my $url_opts    = $self->{url_opts}  || '';
    my $work_path   = $self->{work_path} || '';
    print $self->{in}->header;
    my $css_file    = $self->{in}->cookie('scheme') || 'fileman';
    print qq!
    {cfg}->{html_root_url}/$css_file.css>
        
    

    
    
    
    
    
    
    
    
        
    
    
    
    
    !;
    my $exts = 'cgi pl pm';
    my $files ;
    @$files         = $self->{in}->param('c_edit');
    my $params      = $self->{cgi}->{txt_input};
    my $redirector  = ($self->{cfg}->{winnt} ? " 2>&1 1>&2" : " 1>&1 2>&1");
    foreach  (@$files) {
        my $file      = $self->_safe_file($_, { fullfile => 1, text => 1});
        my $full_name = $file->{file};
        next if (not $file->{text});
        my ($ext)  = $full_name =~ /\.([^.]+)$/;
        next if ($exts !~ /$ext/i);
        my $tmp = $full_name;
        $tmp =~ s,$self->{cfg}->{root_dir}/,,;
        print "
 $tmp ";
        my $check_now = $self->{cfg}->{path_to_perl} . ' -c '.$full_name.' '.$params.' '.$redirector;
        print '
 ',`$check_now`,'
';
        print "";
    }
    print '
';
}
END_OF_SUB

$COMPILE{cmd_diff} = __LINE__ . <<'END_OF_SUB';
sub cmd_diff {
#----------------------------------------------------
# Show difference between two files
#
    my $self = shift;
    my $filename1 = $self->{cgi}->{c_edit};
    my $filename2 = $self->{cgi}->{txt_input};
    my $file1     = $self->_safe_file($filename1, { fullfile => 1, text => 1, exist => 1 });
    my $file2     = $self->_safe_file($filename2, { fullfile => 1, text => 1, exist => 1 });
    ($file1 == -1) and return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_INVALID}, $filename1)}); 
    ($file2 == -1) and return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_INVALID}, $filename2)});

    my $work_path = $self->{work_path} || '';    
    my $fullfile1 = $file1->{file};
    my $fullfile2 = $file2->{file};

    ($file2->{exist}) or return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_FILE_NOT_EXISTS},$filename2)});
    ($file1->{text})  or return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_NOT_TEXT_FILE}  ,$filename1)});
    ($file2->{text})  or return $self->cmd_main_display({ reload => '1', status => sprintf($LANGUAGE{ERR_NOT_TEXT_FILE}  ,$filename2)});
    my ($f1, $f2);
    open (F1, $fullfile1) or die sprintf($LANGUAGE{ERR_FILE_OPEN}, $fullfile1, "$!");
    chomp(@$f1 = );
    close F1;
    open (F2, $fullfile2) or die sprintf($LANGUAGE{ERR_FILE_OPEN}, $fullfile1, "$!");
    chomp(@$f2 = );
    close F2;
    require GT::FileMan::Diff;
    my $diff = GT::FileMan::Diff::main_diff($f1, $f2);
    $diff &&= $self->{in}->html_escape($diff);
    my $back_btn = ($self->{cgi}->{hide_back_button})?'':"";
    print $self->{in}->header;
    my $css_file    = $self->{in}->cookie('scheme') || 'fileman';
    print qq!
    {cfg}->{html_root_url}/$css_file.css>
        
    

    $back_btn
    
    
    
    
    
    
    
    
        
    
    
    
    
$diff

!;

}
END_OF_SUB

$COMPILE{cmd_tar} = __LINE__ . <<'END_OF_SUB';
sub cmd_tar {
#----------------------------------------------------
#   Create tar file
#
    my ($self, $fl) = @_;
    return $self->_tar_information($fl) if ($fl); #show information of this file
   
    my $input     = $self->{cgi}->{txt_input};    
    my $opt_gz    = $self->{cgi}->{opt_gz};
    my $from_path = $self->_safe_dir();   
    my $fulldir   = $self->_safe_dir($input);
    ($fulldir == -1) and return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_INVALID},$input)}); # not safe

    my $fullfile = $fulldir->{fulldir};
    my $path     = [split /\//,$fullfile];
    my $tar_file = @$path[$#$path];
    my $to_path  = $fullfile;
    $to_path     =~ s/\/@$path[$#$path]//; #path to save tar file

    (-e $to_path) or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_TAR_NOT_EXISTS},$input)});    # check exists the directory
    (-w $to_path) or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_TAR_PEM},$input)});           # check permission on this directory
    if ($opt_gz) {
        $tar_file =~ s,.tar,,;
        ($tar_file =~ m,.tar.gz,) or ($tar_file .= '.tar.gz');
    }
    else {
        ($tar_file =~ m,.tar,) or ($tar_file .= '.tar');
    }    
    $fullfile = "$to_path/$tar_file";
    if (!$self->{cgi}->{confirm}) {
        if (-e $fullfile) {
            my $results;
            my $files = [$self->{in}->param('c_edit')];        
            foreach my $file (@$files) {
                push @$results, {name => $file};
            }
            return $self->page('tar_confirm.html', { results => $results,
                                                     file    => $tar_file});            
        }
    }
    $self->_tar_process($fullfile);
}

sub _tar_process {
#--------------------------------------------------------------
#   Create tar file
#   
    my ($self,$to) = @_;   
    
    my $opt_gz    = $self->{cgi}->{opt_gz};
    my $from      = $self->_safe_dir();

    if ($self->{cgi}->{cancel}) { #canceled create tar file
        $self->{cgi}->{cmd_do} = 'cmd_tar';
        return $self->cmd_main_display({ reload => 1, status => $LANGUAGE{MSG_TAR_CANCEL}}); 
    }

    my $input   = $self->{cgi}->{txt_input};
    my $files   = [$self->{in}->param('c_edit')];
    my $history = 'cmd_tar|';
# Make sure tar file goes out of scope and cleans up temp files    
    {
        my $tar;
        require GT::Tar;
        $tar = new GT::Tar($to) or return $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{ERR_TAR},$GT::Tar::error)});           
        foreach my $file (@$files) {
            my $fulldir = $self->_safe_dir($file);
            next if ($fulldir == 1);
            $tar->add_file($fulldir->{fulldir});
            $history .= "$fulldir->{fulldir}:";            
        }
        chop $history;
        
        my $items = $tar->files;
        foreach my $fl (@$items) {
            $fl->{name} =~ s/$from\///;
        }
        $tar->write("$to");
        $history .= "|$to";
    }
    $self->{cgi}->{cmd_do} = 'cmd_tar';
    $to                    =~ s/$self->{cfg}->{root_dir}//;

    $self->history($history) if ( $self->{cfg}->{multi} ); #save log info
    $self->cmd_main_display({ reload => 1, status => sprintf($LANGUAGE{MSG_TAR_CREATED},$to)});    
}
END_OF_SUB

$COMPILE{cmd_uncompress} = __LINE__ . <<'END_OF_SUB';
sub cmd_uncompress {
#--------------------------------------------------------
#   Uncompress .tar or .gz file
#
    my $self = shift;   

    my $root_path  = $self->{cfg}->{root_dir};
    my $work_path  = $self->{work_path}        || ''; 
    my $input      = $self->{cgi}->{txt_input} || "/$work_path";
    my $total_size = $self->{cgi}->{total_size};       
    my $fullfile   = $self->_safe_file($self->{cgi}->{cmp_file}, {fullfile => 1, exist => 1});
    ($fullfile == -1)    and die (sprintf($LANGUAGE{ERR_INVALID},$self->{cgi}->{cmp_file}));
    ($fullfile->{exist}) or  die (sprintf($LANGUAGE{ERR_FILE_NOT_EXISTS},$self->{cgi}->{cmp_file}));
    
    my $cmp_file = $fullfile->{file};
    
    my $fulldir = $self->_safe_dir($input, { exist => 1, write => 1 });
    ($fulldir == -1) and return $self->_tar_information($cmp_file, sprintf($LANGUAGE{ERR_INVALID}, $input));

    my $full_path = $fulldir->{fulldir};
   
# check free space and writeable
    if ( $self->{cfg}->{allowed_space} > 0 ) {
        my @disk_space = $self->_checkspace($full_path);
        my $free_space = $disk_space[0];       
        ($total_size > $free_space*1024 ) and return $self->_tar_information($cmp_file,sprintf($LANGUAGE{ERR_DISK_SPACE},$free_space));
    }

# Check the directory is exists, permission
    ($fulldir->{exist}) or return $self->_tar_information($self->{cgi}->{cmp_file},sprintf($LANGUAGE{ERR_DIR_NOT_EXISTS},$input || $work_path || 'Root'));
    ($fulldir->{write}) or return $self->_tar_information($self->{cgi}->{cmp_file},sprintf($LANGUAGE{ERR_DIR_PEM}       ,$input || $work_path || 'Root'));

    my $files = [$self->{in}->param('c_edit')];
    return $self->_tar_information($cmp_file,$LANGUAGE{ERR_UNCOMPRESS}) if ($#$files == -1);
    
    $COPIED      = 0;
    my $filename = $cmp_file;
    $filename    =~ s/$full_path\///;
    $self->page('progress_bar.html', { bar_name => "Un-tarring:", msg => sprintf($LANGUAGE{MSG_READING}, $filename) });

# Make sure tar file goes out of scope before loading directory.
    {
        my ($fl_tars,$tar);    
        require GT::Tar;  
        $tar = GT::Tar->open ($cmp_file);                           
        $fl_tars = $tar->files;
        foreach my $fl ( @$fl_tars ) {        
            my $found = 0;        
            foreach my $file (@$files) {
                if ($file eq $fl->{name}) {
                    $found = 1;
                    last;
                }
            }

            my $s = $fl->{size};
            $COPIED += $s;           
            if ( $found ) {     
                my $name    = "$full_path/$fl->{name}";
                $fl->{name} = $name;
                $fl->write();
            }
            my $progress = _load_progress_bar($COPIED, $s, $total_size);
            $self->page('copy_status.html', { msg     => "$fl->{name} file...", 
                                              pxs     => $progress->{pxs}, 
                                              percent => $progress->{percent}
            });
        }   
    }
    $self->history("cmd_untar|$filename|$full_path") if ( $self->{cfg}->{multi} ); #save log info
     
    $self->{cgi}->{cmd_do} = 'cmd_tar';
    $filename =~ s,$root_path/,,;
    $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{MSG_UNCOMPRESS},$filename)});    
}
END_OF_SUB

$COMPILE{cmd_passwd} = __LINE__ . <<'END_OF_SUB';
sub cmd_passwd {
# ------------------------------------------------------------------
# Save username and password
#
    my $self = shift;
    my $pass_path = $self->{in}->cookie('def_passwd_dir');
    my $work_path = $self->{work_path} || '';
    my $url_opts  = $self->{url_opts}  || '';    

    my $htpasswd;
    if ($pass_path) { # create .htaccess and .htpasswd in Password directory
        my $file_name  = $self->_safe_dir();
        $file_name =~ s/[\/ \:]/\_/g;
        $htpasswd = "$pass_path/.htpass$file_name";
        if (!-e $htpasswd) {
            open (FILE, "> $htpasswd");
            close FILE;
        }
    }
    else {
        my $fpasswd  = $self->_safe_file(".htpasswd", { fullfile => 1, exist => 1, size => 1});
        $htpasswd = $fpasswd->{file};
        if (!$fpasswd->{exist}) {
            open (FILE, "> $htpasswd");
            close FILE;
        }
    }
    my $faccess  = $self->_safe_file(".htaccess", { fullfile => 1, exist => 1, size => 1});    
    my $htaccess = $faccess->{file};
    if (!$faccess->{exist}) {
        open (FILE, "> $htaccess");
        close FILE;
    }

    unless (-w $htaccess and -w $htpasswd) { #check writeable
        print $self->{in}->header;
        print  sprintf($LANGUAGE{ERR_FILE_PERM},$htaccess,$htpasswd),'
', sprintf($LANGUAGE{MSG_CONTINUE},$self->{http_ref},$work_path,$url_opts);
        return;
    }

    if ( !$faccess->{exist} or $faccess->{size} == 0 ) {
        _create_htaccess($htaccess, $htpasswd);
    }
    else {
        open (HTACC, "< $htaccess") or die "Unable to open: $htpasswd ($!)";
        my @info = ;
        close HTACC;
        my $found; 
        LINE: foreach ( @info ) { 
            if ( $_ =~ /$htpasswd/ ) { 
                $found = 1; 
                last; 
            } 
        } 
        _create_htaccess($htaccess, $htpasswd) if ( !$found );
    }

    if ($self->{cgi}->{remove_all}) {   
        if (! unlink($htpasswd)) {
            open (HTPAS, "> $htpasswd") or die "Unable to open: $htpasswd ($!)";
            close HTPAS;
        }
        if (!unlink($htaccess)) {; # delete file
            open (HTACC, "> $htaccess") or die "Unable to open: $htaccess ($!)";
            close HTACC;
        }                

        return $self->page('protect_directory.html',{msg => $LANGUAGE{MSG_PROTECT}});
    }
    my (@users,$msg);
    my $username  = $self->{cgi}->{p_username} || '';  
    my $password  = $self->{cgi}->{p_password} || '';  
    my $to_delete = ($self->{cgi}->{remove})? $self->{cgi}->{delete_user} : $username;
  
    if ($to_delete) {
        open (HTPAS, "< $htpasswd") or die "Unable to open: $htpasswd ($!)";
        @users = grep { $_ !~ /^$to_delete:/ } ;
        close HTPAS;
        $msg = "$to_delete user deleted.";
    }

    if ($username and $password) {
        my @salt_chars = ('A' .. 'Z', 0 .. 9, 'a' .. 'z', '.', '/');
        my $salt = join '', @salt_chars[rand 64, rand 64];
        my $encrypted = crypt($password, $salt);
        push @users, "$username:$encrypted\n";
        $msg = "$username user added.";
    }
    if (($username and $password) or $to_delete) {
        open (HTPAS, "> $htpasswd") or die "Unable to open: $htpasswd ($!)";
        print HTPAS join ("", @users);
        close HTPAS;
        if (! @users) {
            if (! unlink($htpasswd)) {
            open (HTPAS, "> $htpasswd") or die "Unable to open: $htpasswd ($!)";
            close HTPAS;
            }
            if (!unlink($htaccess)) {; # delete file
                open (HTACC, "> $htaccess") or die "Unable to open: $htaccess ($!)";
                close HTACC;
            }      
        }
    }
    $self->cmd_show_passwd($msg);    
}
END_OF_SUB

$COMPILE{cmd_show_passwd} = __LINE__ . <<'END_OF_SUB';
sub cmd_show_passwd {
# ------------------------------------------------------------------
# Show protect directory page
#
    my ($self,$msg) = @_;
    my $pass_path = $self->{in}->cookie('def_passwd_dir');

    my ($htpasswd,$exist);
    if (!$self->{cfg}->{passwd_dir_level} and !$pass_path =~ /^$self->{cfg}->{root_dir}/) {
         print $self->{in}->header (-cookie => [ $self->{in}->cookie ( -name    => 'def_passwd_dir',  -value   => '0', -expires => '+5y')]);
        $pass_path = '';
    }

    if ($pass_path) { # create .htaccess and .htpasswd in Password directory
        my $file_name  = $self->_safe_dir();
        $file_name =~ s/[\/ \:]/\_/g;
        $htpasswd = "$pass_path/.htpass$file_name";
        
        $exist = 1 if (-e $htpasswd);
    }
    else {
        my $fpasswd   = $self->_safe_file(".htpasswd", {fullfile => 1, exist => 1}); 
        $htpasswd = $fpasswd->{file};
        $exist = 1 if ($fpasswd->{exist});
    }
    my $faccess = $self->_safe_file(".htaccess", {fullfile => 1, exist => 1}); 
    my $htaccess  = $faccess->{file};

    my $delete_list;
    if ($exist and $faccess->{exist}) {
        open (HTPAS, "< $htpasswd") or die "Unable to open: $htpasswd ($!)";
        my @users = ;
        close HTPAS;
        $delete_list = '' if (@users);
    }
    
    $self->page('protect_directory.html',{delete_list => $delete_list, msg => $msg, pass_path => $pass_path});    
}
END_OF_SUB

$COMPILE{printenv} = __LINE__ . <<'END_OF_SUB';
sub printenv {
# ------------------------------------------------------------------
    my $self = shift;   
    ($self->{cfg}->{multi}) and die "It doesn't support for this version";

    my $work_path   = $self->{work_path} || '';
    print $self->{in}->header ;
    print qq!
            

                        
            
            
            
            
            
            
            
            
            
            

!;
    print $self->_environment();
}
END_OF_SUB

sub history {
#---------------------------------------------------------------------    
# Save the history 
#    
    my ($self,$content) = @_;
    return if (!$content);
    
    my $priv_path = $self->{cfg}->{priv_path};
    my $db_name   = 'fileman_history.db';
    
    $content = $self->{cfg}->{username}.'|'.%ENV->{'REMOTE_ADDR'}.'|'.time."|$content\n";
    open (DATA,">>$priv_path/$db_name") or die sprintf($LANGUAGE{ERR_OPEN_FILE}, $db_name, $!);
        flock(DATA, 2);
        print DATA $content;
    close DATA;
}

sub _environment {
# --------------------------------------------------------------------
# Return HTML formatted environment for error messages.
#
    my $self = shift;   
    my $info = '
';

# Print GT::SQL error if it exists.
    $info .= "System Information\n======================================\n";
    $info .= "Perl Version: $]\n";
    $info .= "FileMan Version: $self->{cfg}->{version}" if ($self->{cfg}->{version});
    $info .= "\n"; 
    my $cmds = $self->{commands};
    foreach  (keys %$cmds) {
        $info .= $_."\t:";
        $info .= ($cmds->{$_})?('enabled'):('disabled');
        $info .= "\n"; 
    }
    $info .= "Persistant Env: mod_perl ($MOD_PERL) SpeedyCGI ($SPEEDY)\n";
    $info .= "Mod Perl Version: $mod_perl::VERSION\n" if (defined $ENV{GATEWAY_INTERFACE} and ($ENV{GATEWAY_INTERFACE} =~ /perl/i));
    $info .= "\@INC = \n\t" . join ("\n\t", @INC) . "\n";
    $info .= "\$\@: $@\n" if ($@);
    $info .= "\n";

# CGI Parameters and Cookies.
    if (ref $self->{in} eq 'GT::CGI') {
        if ($self->{in}->param) {
            $info .= "CGI INPUT\n======================================\n";
            foreach (sort $self->{in}->param) { $info .= "$_ => " . $self->{in}->param($_) . "\n"; }
            $info .= "\n\n";
        }
        if ($self->{in}->cookie) {
            $info .= "CGI Cookies\n======================================\n";
            foreach (sort $self->{in}->cookie) { $info .= "$_ => " . $self->{in}->cookie($_) . "\n"; }
            $info .= "\n\n";            
        }
    }

# Environement info.
    $info  .= "ENVIRONMENT\n======================================\n";
    foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
    $info .= "
";
    return $info;
}

sub _tar_information {
#----------------------------------------------------------------------
#   Show information about a tar file
#
    my ($self,$filename,$status) = @_;      
    my $fullfile = $self->_safe_file($filename, {fullfile => 1, exist => 1});
    ($fullfile == -1)    and return $self->cmd_main_display({reload => 0, status => sprintf($LANGUAGE{ERR_INVALID},$filename)});
    ($fullfile->{exist}) or  return $self->cmd_main_display({reload => 0, status => sprintf($LANGUAGE{ERR_FILE_NOT_EXISTS},$filename)});
        
    my $cmp_file = $fullfile->{file};
    my $stat     = [stat($cmp_file)];
    if ($cmp_file =~ m,([^/]*[\.tar\.gz]$),) {
        my ($files,$results);

        require GT::Tar;
        my $tar = GT::Tar->open ($cmp_file) or return $self->cmd_main_display({reload => 1, status => sprintf($LANGUAGE{ERR_FILE_OPEN},$!)}); 
        $files   = $tar->files;
        my $total_size = 0;
        my $html_url   = $self->{cfg}->{html_root_url} || '';
        foreach my $file (@$files) {                 
            $total_size += $file->{size};
            my $spec     = _get_icon($file->{name});
            push @$results, {icon   => "{icon}."' width=14 height=16>", 
                             name   => $file->{name},
                             size   => ($file->{type} eq '5')? '': _print_filesize($file->{size}),
                             date   => _make_date_string($file->{mtime}),
                             chmod  => _print_permissions($file->{mode}),
                             uid    => eval { getpwuid($file->{uid}); } || '',
                             type   => $file->{type},
                             nsize  => ($file->{type} eq '5')? '': $file->{size}
                             }; 
        }
        my $root_path = $self->{cfg}->{root_dir};
        my $url_opts  = $self->{url_opts}  || '';
        my $work_path = $self->{work_path} || '';
        my $full_path = $root_path.(($work_path)?'/':'').$work_path;
        my $filename  = $cmp_file;
        $filename     =~ s/$full_path\///;
        if (!$status) {
            $status = sprintf($LANGUAGE{MSG_FILE_EDITING},'The content of ',$filename,-s $cmp_file,$filename);
        }
        $self->page('tar_information.html', {results     => $results,
                                             count       => $#$files+1,
                                             cmp_file    => $filename,
                                             user        => eval { getpwuid(@$stat[4]); } || '',
                                             total_size  => $total_size,
                                             total_space => $total_size,
                                             num_objects => ($#$results >=0)? $#$results+1:0,
                                             status      => $status});     
    }      
}

sub _checkspace {
# -----------------------------------------------------
# Check for allowed disk space to determine whether we can allow
# editing or uploads.
#
    my $self = shift;    
    my ($directory) = shift;
    my ($size, $used_space, $free_space) = (0,0,0);
    my $files = subdir(1,0,$directory);
    foreach (@$files) {
        $size += -s $_;
    }
    $used_space = int ($size / 1024);
    $free_space = (($self->{cfg}->{'allowed_space'}/1024) - $used_space);
    return ($free_space, $self->{cfg}->{'allowed_space'}/1024, $used_space);
}

sub _file_info {
#------------------------------------------------------------------
# Show file information
#
    my ($self,$fullfile) = @_;
    my $hash;

    my $url_opts    = $self->{url_opts}  || '';
    my $url         = "$self->{http_ref}?fdo=cmd_main_display&$url_opts";
    my $html_url    = $self->{cfg}->{html_root_url};
    my $name        = $fullfile; 
    my $work_path   = $self->{work_path} || '';
    my $full_path   = $self->{cfg}->{root_dir}.'/'.$work_path.(($work_path)?'/':'');
    $name           =~ s/$full_path//; 
    my $stat        = [stat($fullfile)];
    $hash->{value}  = $fullfile;

    if (-d _) {       
       $hash->{name} = $name;
       $hash->{icon} = "";
       $hash->{type} = 'Folder';
       $hash->{isdir}= '1';
       $hash->{size} = '';
    }
    else {
       my $spec       = _get_icon($fullfile);
       $hash->{name}  = $name;
       $hash->{icon}  = "{icon}."' width=14 height=16>"; 
       $hash->{type}  = $spec->{type};
       $hash->{isdir} = '0';
       $hash->{size}  = @$stat[7];
       $hash->{nsize} = @$stat[7];
    }   
    $hash->{date} = @$stat[9];
    $hash->{perm} = @$stat[2];
    my $user      = eval { getpwuid(@$stat[4]); } || '';
    $hash->{user} = $user;
    return $hash;
}

sub speed_bar {
# ------------------------------------------------------------------
# Create a speed bar
#
    my($self,$rows,$url) = @_;    
    my $work_path = $self->{work_path} || '';
    my $sb        = $self->{cgi}->{sb} || '';
    my $sd        = $self->{cgi}->{sd} || '';
    my $url_opts  = $self->{url_opts}  || '';
    $url        ||= "$self->{http_ref}?fdo=cmd_main_display&work_path=$work_path&sb=$sb&sd=$sd&$url_opts";
    my $cur_pg    = $self->{cgi}->{pg} || '1';
    my $pg        = ($cur_pg eq 'all')? 1 : $cur_pg;
    my $rows_pg   = $self->{in}->cookie('def_files_page') || 25;
    my $scre_pg   = $self->{in}->cookie('def_pages_screen') || 10;
    my $pages     = int($rows / $rows_pg) + (($rows % $rows_pg > 0)? 1:0);        

    my ($speed_bar,$pg_step,$start,$jj);
    if ( $scre_pg > 0 ) {
        $pg_step = ($pg % $scre_pg >0) ? int($pg/$scre_pg)+1 : ($pg/$scre_pg);
    }        
    $start   = 1;

    if ($pages > $scre_pg) {
        $start = ($pg == $pages)? ($pg-$scre_pg)+1 : (($pg_step-1) * $scre_pg)+1;
        $start = ($pages-$start+1 < $scre_pg)? $start - ($scre_pg-($pages-$start+1)):$start;
    }    

    $speed_bar  =  ($cur_pg eq 'all')? "All " : "All " ;
    $speed_bar .= "<< < " if ($pg > 1);
    $speed_bar .= ($pg > $scre_pg)? '...':'';    

    for my $ii ( $start .. $pages) {        
        $jj++;
        if ($cur_pg eq 'all') {
            $speed_bar .= "$ii "
        }
        else {
            $speed_bar .= ($cur_pg == $ii)? "$ii " : "$ii ";
        }
        if ($jj == $scre_pg) {
            $speed_bar .= ( ($pg_step*$scre_pg) < $pages) ? "..." : "";
            last;
        }
    }

    $speed_bar .= "> >>" if ($pg < $pages);
    return $speed_bar;
}

sub qsort {
# ------------------------------------------------------------------
    my ($self,$list_file,$orderby,$sortdown)  = @_;
    my $sorted;
    @$sorted = 
               sort {
                    my $da = lc $a->{$orderby};         #lower case
                    my $db = lc $b->{$orderby};
                    if ($orderby eq 'size' or $orderby eq 'date') {
                        ($sortdown)?($da <=> $db):($db <=> $da)    #compare
                    }
                    else {
                        ($sortdown)?($da cmp $db):($db cmp $da)   
                    }
                    } @$list_file;
    return $sorted;
}

sub _safe_file {
#------------------------------------------------------------------------
# Check a file make sure it safe
#
    my ($self, $file, $options) = @_;

    my $root = $self->{cfg}->{root_dir};
    my $work = $self->{work_path} ;    
    unless ($file =~ m,^([-\w/. ]+)$, and $file !~ /(\.\.)+/) {       
        return -1;
    }

    my $fullfile = $root . ($work ? '/' : '') . $work . '/' . $file;    

    my ($e,$w,$t,$s,$f);
    foreach my $key (keys % $options) {
        if ($options->{$key} == 1) {                
            ($key eq 'exist')  and $e = -e $fullfile ;
            ($key eq 'write')  and $w = -w $fullfile ;                 
            ($key eq 'text')   and $t = -T $fullfile ;                 
            ($key eq 'size')   and $s = -s $fullfile ;                 
            ($key eq 'isfile') and $f = -f $fullfile ; 
        }
    }
    return {
            file   => ($options->{fullfile} == 1)?$fullfile:$file ,
            exist  => $e, 
            write  => $w,
            text   => $t,
            size   => $s,
            isfile => $f,
    };        
}

sub _view_file {
#------------------------------------------------------
# print the content of a file
#
    my ($self,$filename) = @_;
    my $file = $self->_safe_file($filename,{ fullfile => 1, size => 1});     
    ($file == -1) and return; # not safe

# Load content-type of a image file.
    my $fullfile     = $file->{file};    
    my $file_size    = $file->{size};
    my $content_type = _load_mime($fullfile);
    my ($ext)        = $fullfile =~ /\.([^.]+)$/;

    if(open(DATA, $fullfile)) {
        $self->{in}->reset_env();
        if ((($content_type =~ m/text/) or -T $fullfile) and (uc($ext) ne 'PDF')) {
            my $url_opts  = $self->{url_opts}  || '';
            my $work_path = $self->{work_path} || '';
            print $self->{in}->header;
            print qq!
                   
 
                    
                                
                    
                    
                    
                    
                    
                    
                    
                    
                    
                    
                   
 
                   
    
            !;         
             print '
    ' if (not $content_type =~ m/htm/);
        }
        else {
            print $self->{in}->header({ '-force'          => 1,
                                        '-type'           => $content_type,
                                        '-Content-Length' => $file_size,
                                        }); 
        }
        ($self->{cfg}->{winnt}) and binmode STDOUT;
        binmode DATA;
        my $buffer;
        print $buffer while (read(DATA, $buffer , $READ_SIZE));
        close(DATA);
    }
}

sub _safe_dir {
#------------------------------------------------------------------------
# Check a directory make sure it safe
#
    my ($self, $dir, $options) = @_;

    my $root = $self->{cfg}->{root_dir};
    my $work = $self->{work_path};    
        
    return ($work) ? "$root/$work" : $root if (!$dir);
    unless ($dir =~ m,^([-\w/. ]+)$, and $dir !~ /(\.\.)+/) {       
        return -1;
    }

    my $fulldir;
    ($dir =~ m,^/,) ? ($fulldir = $root . $dir)
                    : ($fulldir = $root. ($work ? '/' : '') . $work . '/' . $dir);        
    my ($e,$d,$w);    
    foreach my $key (keys % $options) {
        if ($options->{$key} == 1) {                
            $e = -e $fulldir if ($key eq 'exist');
            $d = -d $fulldir if ($key eq 'isdir');
            $w = -w $fulldir if ($key eq 'write');                 
        }
    }
    return {fulldir => $fulldir, exist => $e, isdir => $d, write => $w};
}

sub subdir {
#------------------------------------------------------------------------
# list subdir
# 
    my ($excepted_ln,$flag, $name, $stack, $callback) = @_;    
    if (!$callback) {
        ($flag)? push @$stack,{ name => '' , parent => $name}
               : push @$stack,$name;
    }
    if (-d $name) {
        opendir (DIR, $name) or warn sprintf($LANGUAGE{ERR_READ_DIR},$name,$!);
        my $files;
        @$files = readdir(DIR);
        closedir (DIR);
        foreach my $file (@$files) {
            next if ($file eq '.');
            next if ($file eq '..');
            next if ($excepted_ln and -l "$name/$file");
            ($flag)? push @$stack, {name => $file, parent => $name}
                   : push @$stack,"$name/$file";
            if (-d "$name/$file") {
                subdir($excepted_ln,$flag,"$name/$file",$stack,1);
            }
        }            
    }
    return $stack;
}

sub _load_progress_bar {
#---------------------------------------------------
#   Load progress bar
#    
    my ($copied,$s,$total_size) = @_;
    my ($px_bytes,$pxs,$percent);

    require Math::BigFloat;
    $px_bytes = int($total_size/500);
    $percent  = (($copied + $s)*100)/$total_size if ($total_size>0);
    $pxs      = int((500*$percent)/100);
    
    my $f     = new Math::BigFloat $percent;
    $percent  = $f->fround(2)*1;
    $percent  = 100 if ($percent > 100);   
    return {pxs => $pxs, percent => $percent};
}

sub _command_show {
#--------------------------------------------------------------------
# Show path when execute cd command
#
    my ($working_dir, $cmd) = @_;    
    if ($cmd =~ m/^\s*cd\s*\.\./) { # cd ..
        my $tmp;
        my $parts = [split(/\//,$working_dir)]; 
        return '/' if ($#$parts == 1 or $working_dir eq '/');
        
        foreach my $ii( 0 .. $#$parts) {
            $tmp .= '/'.@$parts[$ii] if ($ii < $#$parts and @$parts[$ii]);
        }
        return $tmp;
    }    
    return $working_dir if ($cmd =~ m/^\s*cd\s*\./); # cd.    
    my $path = $cmd;
    $path    =~ s/\s*cd\s*//;
    return '/' if ($path =~ m,^(/+)$,);
    return ($path =~ m/^\//)? $path : $working_dir.(($working_dir and $working_dir ne '/')? '/' : '').$path;
}

sub _get_icon {
# ------------------------------------------------------------------
# Get the associated icon based on a files extension
#    
    my ($file) = shift;
    my ($ext)  = $file =~ /\.([^.]+)$/;
    return {icon => 'unknown.gif', type => 'unknown'} if (!$ext);
    foreach (keys %{$ICONS}) {
        next if (/folder/);
        next if (/unknown/);
        next if (/parent/);
        ($_ =~ /$ext/i) and return { icon => $ICONS->{$_}[0],type => $ICONS->{$_}[1]};
    }
    return {icon => 'unknown.gif', type => 'unknown'};
}

sub _get_date {
# ------------------------------------------------------------------
    my $time = shift;
    $time or ($time = time);
    my @months = qw!Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec!;

    my ($min, $hr, $day, $mon, $yr) = (localtime($time))[1,2,3,4,5];
    $yr = $yr + 1900;
    ($min < 10) and ($min = "0$min");
    ($hr  < 10) and ($hr  = "0$hr");
    ($day < 10) and ($day = "0$day");

    return "$day-$months[$mon]-$yr $hr:$min";
}

sub _print_filesize {
# ------------------------------------------------------------------
# Prints out the file size.
#    
    my $size = shift;
    my $formatted_size = 0;
    $formatted_size = int($size / 1000) if ($size);
    return $formatted_size == 0 ? "$size bytes" : $formatted_size." kb";
}

sub _print_permissions {
# ------------------------------------------------------------------
# Takes permissions in octal and prints out in ls -al format.
#
    my $octal  = shift;
    my $string = sprintf "%lo", ($octal & 07777);
    my $result = '';
    foreach (split(//, $string)) {
        if    ($_ == 7) { $result .= "rwx "; }
        elsif ($_ == 6) { $result .= "rw- "; }
        elsif ($_ == 5) { $result .= "r-x "; }
        elsif ($_ == 4) { $result .= "r-- "; }
        elsif ($_ == 3) { $result .= "-wx "; }
        elsif ($_ == 2) { $result .= "-w- "; }
        elsif ($_ == 1) { $result .= "--x "; }
        elsif ($_ == 0) { $result .= "--- "; }
        else            { $result .= "unkown '$_'!"; }
    }
    return $result;
}

sub _space_used { 
#----------------------------------------------------------
#   Load space used of directory
#
    my $file = shift;
    my $total_size = 0 ;
    
    my $files = subdir(1,0, $file);
    foreach (@$files) {
        $total_size += -s $_;
    }
    return $total_size;
}

sub _make_date_string ($) {    
#------------------------------------------------------------
# format day
#
    my $date = shift;
    my @lt = localtime($date);
    my @month   = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
    my @day     = qw/ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31/;
    my @weekday = qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/;
    return "$day[$lt[3]]-$month[$lt[4]]-".($lt[5]+1900)." ".sprintf("%02d:%02d",@lt[2,1,0]);
}

sub _load_mime {
# --------------------------------------------------------------------
# Load the config file into a hash.
#
    my $file = shift;
    require GT::MIMETypes;
    my $guess = GT::MIMETypes->guess_type($file);
    if (! $guess) {
        if (-e $file) {
            $guess = -T _ ? 'text/plain' : 'application/octet-stream';
        }
        else {
            $guess = 'application/octet-stream';
        }
    }
    return $guess;
}

sub _init_chmod {
#---------------------------------------------------------------------
# set chmod 
#
    my($from,$to) = @_;
    $from =~ m,^([/\w.-]+)$,;
    $from = $1;
    
    $to =~ m,^([/\w.-]+)$,;
    $to = $1;

    my $stat = [stat($from)];
    chmod(@$stat[2],$to);
}

sub _create_htaccess {
# ------------------------------------------------------------------
# Creates the htaccess file.
#
    my ($htaccess, $htpasswd) = @_;
    my $raq = $ENV{GT_COBALT_RAQ} ? "AuthPAM_Enabled off\n" : '';
    open (HTAC, "> $htaccess") or die "Unable to open: $htaccess ($!)";
    print HTAC <$to") or return 0;
    open(SOURCE, "<$from") or return 0;
    binmode SOURCE;
    binmode TARGET;
    my $buffer;
    while (read SOURCE, $buffer, $READ_SIZE) { 
        if ($repl) {
            ($cs)? ($buffer =~ s,$repl,$with,g)
                 : ($buffer =~ s,$repl,$with,ig);
        }
        print TARGET $buffer; 
    }
    close SOURCE;
    close TARGET;
    _init_chmod($from,$to);
    return 1;
}

sub _valid_name_check {
# ---------------------------------------------------
# Checks to see if the input database/table name is a 
# valid one.  The function checks the following:
# 1. if a name is entered at all;
# 2. if there are spaces in the name;
# 3. if the name is consisted of valid characters; and
# 4. if the name is consisted of only numbers.

    my $name = shift;
    my ($output);

    $name =~ s/^\s+//;  
    $name =~ s/\s+$//;

    my @name = split / /, $name;

    if (!$name)        { $output = "Please provide a valid name."; }
    elsif ($#name > 0) { $output = "Spaces are not allowed in name."; }
    return $output;
}

1;
private/lib/GT/FileMan/Diff.pm0100644000076400010020000004004007325702202014627 0ustar  alexcvs# ==================================================================
# File manager - enhanced web based file management system
#
#   Website  : http://gossamer-threads.com/
#   Support  : http://gossamer-threads.com/scripts/support/
#   Revision : $Id: Diff.pm,v 1.4 2001/07/20 01:08:18 alex Exp $
# 
# Copyright (c) 2001 Gossamer Threads Inc.  All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================

package GT::FileMan::Diff;
# ==================================================================
# This module was taken from Algorthim::Diff in almost it's entirity. 
#

use strict;
use vars qw($VERSION @EXPORT_OK @ISA @EXPORT);
use integer;		# see below in _replaceNextLargerWith() for mod to make
					# if you don't use this
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(LCS diff traverse_sequences);
$VERSION = sprintf('%d.%02d', (q$Revision: 1.4 $ =~ /\d+/g));


# Create a hash that maps each element of $aCollection to the set of positions
# it occupies in $aCollection, restricted to the elements within the range of
# indexes specified by $start and $end.
# The fourth parameter is a subroutine reference that will be called to
# generate a string to use as a key.
# Additional parameters, if any, will be passed to this subroutine.
#
# my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );

sub _withPositionsOfInInterval
{
	my $aCollection = shift;	# array ref
	my $start = shift;
	my $end = shift;
	my $keyGen = shift;
	my %d;
	my $index;
	for ( $index = $start; $index <= $end; $index++ )
	{
		my $element = $aCollection->[ $index ];
		my $key = &$keyGen( $element, @_ );
		if ( exists( $d{ $key } ) )
		{
			push( @{ $d{ $key } }, $index );
		}
		else
		{
			$d{ $key } = [ $index ];
		}
	}
	return wantarray ? %d: \%d;
}

# Find the place at which aValue would normally be inserted into the array. If
# that place is already occupied by aValue, do nothing, and return undef. If
# the place does not exist (i.e., it is off the end of the array), add it to
# the end, otherwise replace the element at that point with aValue.
# It is assumed that the array's values are numeric.
# This is where the bulk (75%) of the time is spent in this module, so try to
# make it fast!

sub _replaceNextLargerWith
{
	my ( $array, $aValue, $high ) = @_;
	$high ||= $#$array;

	# off the end?
	if ( $high == -1 || $aValue > $array->[ -1 ] )
	{
		push( @$array, $aValue );
		return $high + 1;
	}

	# binary search for insertion point...
	my $low = 0;
	my $index;
	my $found;
	while ( $low <= $high )
	{
		$index = ( $high + $low ) / 2;
#		$index = int(( $high + $low ) / 2);		# without 'use integer'
		$found = $array->[ $index ];

		if ( $aValue == $found )
		{
			return undef;
		}
		elsif ( $aValue > $found )
		{
			$low = $index + 1;
		}
		else
		{
			$high = $index - 1;
		}
	}

	# now insertion point is in $low.
	$array->[ $low ] = $aValue;		# overwrite next larger
	return $low;
}

# This method computes the longest common subsequence in $a and $b.

# Result is array or ref, whose contents is such that
# 	$a->[ $i ] = $b->[ $result[ $i ] ]
# foreach $i in ( 0..scalar( @result ) if $result[ $i ] is defined.

# An additional argument may be passed; this is a hash or key generating
# function that should return a string that uniquely identifies the given
# element.  It should be the case that if the key is the same, the elements
# will compare the same. If this parameter is undef or missing, the key
# will be the element as a string.

# By default, comparisons will use "eq" and elements will be turned into keys
# using the default stringizing operator '""'.

# Additional parameters, if any, will be passed to the key generation routine.

sub _longestCommonSubsequence
{
	my $a = shift;	# array ref
	my $b = shift;	# array ref
	my $keyGen = shift;	# code ref
	my $compare;	# code ref

	# set up code refs
	# Note that these are optimized.
	if ( !defined( $keyGen ) )	# optimize for strings
	{
		$keyGen = sub { $_[0] };
		$compare = sub { my ($a, $b) = @_; $a eq $b };
	}
	else
	{
		$compare = sub {
			my $a = shift; my $b = shift;
			&$keyGen( $a, @_ ) eq &$keyGen( $b, @_ )
		};
	}

	my ($aStart, $aFinish, $bStart, $bFinish, $matchVector) = (0, $#$a, 0, $#$b, []);

	# First we prune off any common elements at the beginning
	while ( $aStart <= $aFinish
		and $bStart <= $bFinish
		and &$compare( $a->[ $aStart ], $b->[ $bStart ], @_ ) )
	{
		$matchVector->[ $aStart++ ] = $bStart++;
	}

	# now the end
	while ( $aStart <= $aFinish
		and $bStart <= $bFinish
		and &$compare( $a->[ $aFinish ], $b->[ $bFinish ], @_ ) )
	{
		$matchVector->[ $aFinish-- ] = $bFinish--;
	}

	# Now compute the equivalence classes of positions of elements
	my $bMatches = _withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
	my $thresh = [];
	my $links = [];

	my ( $i, $ai, $j, $k );
	for ( $i = $aStart; $i <= $aFinish; $i++ )
	{
		$ai = &$keyGen( $a->[ $i ] );
		if ( exists( $bMatches->{ $ai } ) )
		{
			$k = 0;
			for $j ( reverse( @{ $bMatches->{ $ai } } ) )
			{
				# optimization: most of the time this will be true
				if ( $k
					and $thresh->[ $k ] > $j
					and $thresh->[ $k - 1 ] < $j )
				{
					$thresh->[ $k ] = $j;
				}
				else
				{
					$k = _replaceNextLargerWith( $thresh, $j, $k );
				}

				# oddly, it's faster to always test this (CPU cache?).
				if ( defined( $k ) )
				{
					$links->[ $k ] = 
						[ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
				}
			}
		}
	}

	if ( @$thresh )
	{
		for ( my $link = $links->[ $#$thresh ]; $link; $link = $link->[ 0 ] )
		{
			$matchVector->[ $link->[ 1 ] ] = $link->[ 2 ];
		}
	}

	return wantarray ? @$matchVector : $matchVector;
}

sub traverse_sequences
{
	my $a = shift;	# array ref
	my $b = shift;	# array ref
	my $callbacks = shift || { };
	my $keyGen = shift;
	my $matchCallback = $callbacks->{'MATCH'} || sub { };
	my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
	my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
	my $matchVector = _longestCommonSubsequence( $a, $b, $keyGen, @_ );
	# Process all the lines in match vector
	my $lastA = $#$a;
	my $lastB = $#$b;
	my $bi = 0;
	my $ai;
	for ( $ai = 0; $ai <= $#$matchVector; $ai++ )
	{
		my $bLine = $matchVector->[ $ai ];
		if ( defined( $bLine ) )
		{
			&$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
			&$matchCallback( $ai, $bi++, @_ );
		}
		else
		{
			&$discardACallback( $ai, $bi, @_ );
		}
	}

	&$discardACallback( $ai++, $bi, @_ ) while ( $ai <= $lastA );
	&$discardBCallback( $ai, $bi++, @_ ) while ( $bi <= $lastB );
	return 1;
}

sub LCS
{
	my $a = shift;	# array ref
	my $matchVector = _longestCommonSubsequence( $a, @_ );
	my @retval;
	my $i;
	for ( $i = 0; $i <= $#$matchVector; $i++ )
	{
		if ( defined( $matchVector->[ $i ] ) )
		{
			push( @retval, $a->[ $i ] );
		}
	}
	return wantarray ? @retval : \@retval;
}

sub diff
{
	my $a = shift;	# array ref
	my $b = shift;	# array ref
	my $retval = [];
	my $hunk = [];
	my $discard = sub { push( @$hunk, [ '-', $_[ 0 ], $a->[ $_[ 0 ] ] ] ) };
	my $add = sub { push( @$hunk, [ '+', $_[ 1 ], $b->[ $_[ 1 ] ] ] ) };
	my $match = sub { push( @$retval, $hunk ) if scalar(@$hunk); $hunk = [] };
	traverse_sequences( $a, $b,
		{ MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add },
		@_ );
	&$match();
	return wantarray ? @$retval : $retval;
}

sub main_diff {
#-------------------------------------------------------------------------------
# Main diff function
    my ($f1, $f2) = @_;
    my $File_Length_Difference = 0;
    my $Context_Lines = 0; # lines of context to print. 0 for old-style diff
    my $output;
    # diffing
    my ($char1, $char2); # string to print before file names

    # diff yields lots of pieces, each of which is basically a Block object
    my $diffs = diff($f1, $f2);
    return "Two files look identical." unless ($#$diffs != -1);

    my ($hunk,$oldhunk);
    # Loop over hunks. If a hunk overlaps with the last hunk, join them.
    # Otherwise, print out the old one.
    foreach my $piece (@$diffs) {
        $hunk = new Hunk ($piece, $Context_Lines);
        next unless $oldhunk; # first time through

        # Don't need to check for overlap if blocks have no context lines
        if ($Context_Lines && $hunk->does_overlap($oldhunk)) {
        $hunk->prepend_hunk($oldhunk);
        } else {
        $oldhunk->output_old_diff($f1, $f2);
        }

    } continue {
        $oldhunk = $hunk;
    }

    # print the last hunk
    $oldhunk->output_old_diff($f1, $f2);

    return $output;
    # END MAIN PROGRAM

    ########
    # Package Hunk. A Hunk is a group of Blocks which overlap because of the
    # context surrounding each block. (So if we're not using context, every
    # hunk will contain one block.)
    {
    package Hunk;

    sub new {
    # Arg1 is output from &LCS::diff (which corresponds to one Block)
    # Arg2 is the number of items (lines, e.g.,) of context around each block
    #
    # This subroutine changes $File_Length_Difference
    #
    # Fields in a Hunk:
    # blocks      - a list of Block objects
    # start       - index in file 1 where first block of the hunk starts
    # end         - index in file 1 where last block of the hunk ends
    #
    # Variables:
    # before_diff - how much longer file 2 is than file 1 due to all hunks
    #               until but NOT including this one
    # after_diff  - difference due to all hunks including this one
        my ($class, $piece, $context_items) = @_;

        my $block = new Block ($piece); # this modifies $FLD!

        my $before_diff = $File_Length_Difference; # BEFORE this hunk
        my $after_diff = $before_diff + $block->{"length_diff"};
        $File_Length_Difference += $block->{"length_diff"};
        my @remove_array = $block->remove;
        my @insert_array = $block->insert;
        my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2);
        $a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1;
        $a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1;
        $b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1;
        $b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1;

        $start1 = $a1 == -1 ? $b1 - $before_diff : $a1;
        $end1   = $a2 == -1 ? $b2 - $after_diff  : $a2;
        $start2 = $b1 == -1 ? $a1 + $before_diff : $b1;
        $end2   = $b2 == -1 ? $a2 + $after_diff  : $b2;

        # At first, a hunk will have just one Block in it
        my $hunk = {
            "start1" => $start1,
            "start2" => $start2,
            "end1" => $end1,
            "end2" => $end2,
            "blocks" => [$block],
                  };
        bless $hunk, $class;

        $hunk->flag_context($context_items);

        return $hunk;
    }

    # Change the "start" and "end" fields to note that context should be added
    # to this hunk
    sub flag_context {
        my ($hunk, $context_items) = @_;
        return unless $context_items; # no context

        # add context before
        my $start1 = $hunk->{"start1"};
        my $num_added = $context_items > $start1 ? $start1 : $context_items;
        $hunk->{"start1"} -= $num_added;
        $hunk->{"start2"} -= $num_added;

        # context after
        my $end1 = $hunk->{"end1"};
        $num_added = ($end1+$context_items > $#$f1) ?
                      $#$f1 - $end1 :
                      $context_items;
        $hunk->{"end1"} += $num_added;
        $hunk->{"end2"} += $num_added;
    }

    # Is there an overlap between hunk arg0 and old hunk arg1?
    # Note: if end of old hunk is one less than beginning of second, they overlap
    sub does_overlap {
        my ($hunk, $oldhunk) = @_;
        return "" unless $oldhunk; # first time through, $oldhunk is empty

        # Do I actually need to test both?
        return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 ||
                $hunk->{"start2"} - $oldhunk->{"end2"} <= 1);
    }

    # Prepend hunk arg1 to hunk arg0
    # Note that arg1 isn't updated! Only arg0 is.
    sub prepend_hunk {
        my ($hunk, $oldhunk) = @_;

        $hunk->{"start1"} = $oldhunk->{"start1"};
        $hunk->{"start2"} = $oldhunk->{"start2"};

        unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}});
    }


    # DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO...

    sub output_old_diff {
    # Note that an old diff can't have any context. Therefore, we know that
    # there's only one block in the hunk.
        my ($hunk, $fileref1, $fileref2) = @_;
        my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c');

        my @blocklist = @{$hunk->{"blocks"}};
        warn ("Expecting one block in an old diff hunk!") if scalar @blocklist != 1;
        my $block = $blocklist[0];
        my $op = $block->op; # +, -, or !

        # Calculate item number range.
        # old diff range is just like a context diff range, except the ranges
        # are on one line with the action between them.
        my $range1 = $hunk->context_range(1);
        my $range2 = $hunk->context_range(2);
        my $action = $op_hash{$op} || warn "unknown op $op";
        $output .= "$range1$action$range2\n";

        # If removing anything, just print out all the remove lines in the hunk
        # which is just all the remove lines in the block
        if ($block->remove) {
            my @outlist = @$fileref1[$hunk->{"start1"}..$hunk->{"end1"}];
            map {$_ = "< $_\n"} @outlist; # all lines will be '< text\n'
            foreach (@outlist){
                $output .= $_;
            }
        }

        $output .= "---\n" if $op eq '!'; # only if inserting and removing
        if ($block->insert) {
            my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}];
            map {$_ = "> $_\n"} @outlist; # all lines will be '> text\n'
            foreach (@outlist){
                $output .= $_;
            }
        }
    }



    sub context_range {
    # Generate a range of item numbers to print. Only print 1 number if the range
    # has only one item in it. Otherwise, it's 'start,end'
    # Flag is the number of the file (1 or 2)
        my ($hunk, $flag) = @_;
        my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
        $start++; $end++;  # index from 1, not zero
        my $range = ($start < $end) ? "$start,$end" : $end;
        return $range;
    }


    } # end Package Hunk

    ########
    # Package Block. A block is an operation removing, adding, or changing
    # a group of items. Basically, this is just a list of changes, where each
    # change adds or deletes a single item.
    # (Change could be a separate class, but it didn't seem worth it)
    {
    package Block;
    sub new {
    # Input is a chunk from &Algorithm::LCS::diff
    # Fields in a block:
    # length_diff - how much longer file 2 is than file 1 due to this block
    # Each change has:
    # sign        - '+' for insert, '-' for remove
    # item_no     - number of the item in the file (e.g., line number)
    # We don't bother storing the text of the item
    #
        my ($class,$chunk) = @_;
        my @changes = ();

    # This just turns each change into a hash.
        foreach my $item (@$chunk) {
        my ($sign, $item_no, $text) = @$item;
        my $hashref = {"sign" => $sign, "item_no" => $item_no};
        push @changes, $hashref;
        }

        my $block = { "changes" => \@changes };
        bless $block, $class;

        $block->{"length_diff"} = $block->insert - $block->remove;
        return $block;
    }


    # LOW LEVEL FUNCTIONS
    sub op {
    # what kind of block is this?
        my $block = shift;
        my $insert = $block->insert;
        my $remove = $block->remove;

        $remove && $insert and return '!';
        $remove and return '-';
        $insert and return '+';
        warn "unknown block type";
        return '^'; # context block
    }

    # Returns a list of the changes in this block that remove items
    # (or the number of removals if called in scalar context)
    sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; }

    # Returns a list of the changes in this block that insert items
    sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; }

    } # end of package Block

}

1;
private/lib/GT/MIMETypes.pm0100644000076400010020000003256607453737207014255 0ustar  alexcvs# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::MIMETypes
#   Author  : Scott Beck
#   $Id: MIMETypes.pm,v 1.13 2002/04/07 03:35:35 jagerman Exp $
#
# Copyright (c) 2000 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description:
#   Provides methods to guess mime types.
#

package GT::MIMETypes;
# ===================================================================
use strict;
use vars qw/%CONTENT_EXT %MIME_EXT %MIME_TYPE/;
use GT::AutoLoader;

$COMPILE{guess_type} = __LINE__ . <<'END_OF_SUB';
sub guess_type {
# -------------------------------------------------------------------
# Makes it's best guess based on input. Returns application/octet-stream
# on failure to guess.
# Possible arguments
#{
#   filename => name of the file
#   filepath => full path to the file
#}
# No arguments are required but you will get application/octet-stream
# with no arguments.
#
    my ($class, $msg) = @_;

    if (!ref $msg) {
        defined(%CONTENT_EXT) or content_ext();
        if ($msg =~ /\.([^.]+)$/ and exists $CONTENT_EXT{lc $1}) {
            return $CONTENT_EXT{lc $1};
        }
        else {
            return 'application/octect-stream';
        }
    }

# If we have a filename with an extention use that
    if ($msg->{filename} or $msg->{filepath}) {
        my $f;
        if ($msg->{filename}) {
            $f = $msg->{filename};
        }
        else {
            $f = $msg->{filepath};
        }
        defined(%CONTENT_EXT) or content_ext();
        if ($f =~ /\.([^.]+)$/ and exists $CONTENT_EXT{lc $1}) {
            return $CONTENT_EXT{lc $1};
        }
    }
    return 'application/octet-stream';
}
END_OF_SUB

$COMPILE{guess_image} = __LINE__ . <<'END_OF_SUB';
sub guess_image {
# -------------------------------------------------------------------
# Makes it's best guess based on input. Returns unknown.gif
# on failure to guess.
# Possible arguments
#{
#   filename => name of the file
#   filepath => full path to the file
#   type     => mime type
#}
# No arguments are required but you will get unknown.gif
# with no arguments.
#
    my ($class, $msg) = @_;
    my $image;

    if (!ref $msg) {
        if ($msg =~ /\.([^.]+)$/) {
            defined(%MIME_EXT) or mime_ext();
            return $MIME_EXT{lc $1} || 'unknown.gif';
        }
        else {
            return 'unknown.gif';
        }
    }
    if ($msg->{filepath} and -d $msg->{filepath}) {
        return 'folder.gif';
    }

# If we have a filename with an extention use that
    my $f;
    if ($msg->{filename} or $msg->{filepath}) {
        if ($msg->{filename}) {
            $f = $msg->{filename};
        }
        else {
            $f = $msg->{filepath};
        }
        defined(%MIME_EXT) or mime_ext();
        if ($f =~ /\.([^.]+)$/ and exists $MIME_EXT{lc $1}) {
            return $MIME_EXT{lc $1};
        }
    }

# If a content type was passed in see if we know anything about it
    defined(%MIME_TYPE) or mime_type();
    if (exists $MIME_TYPE{$msg->{type} || $msg->{mime_type}}) {
        return $MIME_TYPE{$msg->{type} || $msg->{mime_type}};
    }

# No luck so far, resort to other means
    elsif ($msg->{filepath} and -B $msg->{filepath}) {
        return 'binary.gif';
    }
    elsif ($f and lc($f) =~ /readme/) {
        return 'readme.gif';
    }
    elsif ($msg->{filepath} and -T _) {
        return 'txt.gif';
    }

# Oops nothing
    return 'unknown.gif';
}
END_OF_SUB

$COMPILE{mime_ext} = __LINE__ . <<'END_OF_SUB';
sub mime_ext {
# -------------------------------------------------------------------
# Map file extention to image file
#
    %MIME_EXT = (
        css         => 'html.gif',
        htm         => 'html.gif',
        html        => 'html.gif',
        shtm        => 'html.gif',
        shtml       => 'html.gif',
        text        => 'txt.gif', 
        c           => 'source.gif', 
        cc          => 'source.gif', 
        'c++'       => 'source.gif',
        h           => 'source.gif', 
        pl          => 'source.gif',
        pm          => 'source.gif',
        cgi         => 'source.gif', 
        txt         => 'txt.gif', 
        eml         => 'email.gif',
        email       => 'email.gif',
        mime        => 'email.gif',
        java        => 'source.gif', 
        el          => 'source.gif',
        pdf         => 'pdf.gif',
        dvi         => 'dvi.gif',
        eds         => 'postscript.gif',
        ai          => 'postscript.gif',
        ps          => 'postscript.gif',
        tex         => 'tex.gif',
        texinfo     => 'tex.gif',
        tar         => 'tar.gif',
        ustar       => 'tar.gif',
        zip         => 'tgz.gif',
        tgz         => 'tgz.gif',
        gz          => 'tgz.gif',
        snd         => 'sound.gif',
        au          => 'sound.gif',
        aifc        => 'sound.gif',
        aif         => 'sound.gif',
        aiff        => 'sound.gif',
        wav         => 'sound.gif',
        bmp         => 'image.gif',
        gif         => 'image.gif',
        ief         => 'image.gif',
        jfif        => 'image.gif',
        'jfif-tbnl' => 'image.gif',
        jpe         => 'image.gif',
        jpg         => 'image.gif',
        jpeg        => 'image.gif',
        tif         => 'image.gif',
        tiff        => 'image.gif',
        fpx         => 'image.gif',
        fpix        => 'image.gif',
        ras         => 'image.gif',
        pnm         => 'image.gif',
        pbn         => 'image.gif',
        pgm         => 'image.gif',
        ppm         => 'image.gif',
        rgb         => 'image.gif',
        xbm         => 'image.gif',
        xpm         => 'image.gif',
        xwd         => 'image.gif',
        png         => 'image.gif',
        mpg         => 'video.gif',
        mpe         => 'video.gif',
        mpeg        => 'video.gif',
        mov         => 'video.gif',
        qt          => 'video.gif',
        avi         => 'video.gif',
        movie       => 'video.gif',
        mv          => 'video.gif',
        sh          => 'shellscript.gif',
        rpm         => 'rpm.gif',
        ttf         => 'font_true.gif'
    ) unless keys %MIME_EXT;

    %MIME_EXT;
}
END_OF_SUB

$COMPILE{content_ext} = __LINE__ . <<'END_OF_SUB';
sub content_ext {
# -------------------------------------------------------------------
# To guess the content-type for files by extention
#
    %CONTENT_EXT = (
        doc         => 'application/msword',
        ppt         => 'application/mspowerpoint',
        oda         => 'application/oda', 
        pdf         => 'application/pdf', 
        eds         => 'application/postscript', 
        ai          => 'application/postscript',
        ps          => 'application/postscript', 
        rtf         => 'application/rtf', 
        dvi         => 'application/x-dvi', 
        hdf         => 'application/x-hdf',
        latex       => 'application/x-latex', 
        nc          => 'application/x-netcdf', 
        cdf         => 'application/x-netcdf', 
        tex         => 'application/x-tex',
        texinfo     => 'application/x-texinfo', 
        texi        => 'application/x-texinfo', 
        t           => 'application/x-troff', 
        tr          => 'application/x-troff',
        roff        => 'application/x-troff', 
        man         => 'application/x-troff-man', 
        me          => 'application/x-troff-me', 
        ms          => 'application/x-troff-ms',
        src         => 'application/x-wais-source', 
        wsrc        => 'application/x-wais-source', 
        zip         => 'application/zip', 
        bcpio       => 'application/x-bcpio',
        cpio        => 'application/x-cpio', 
        gtar        => 'application/x-gtar', 
        sh          => 'application/x-shar', 
        shar        => 'application/x-shar',
        sv4cpio     => 'application/x-sv4cpio', 
        sv4crc      => 'application/x-sv4crc', 
        tar         => 'application/x-tar', 
        ustar       => 'application/x-ustar',
        snd         => 'audio/basic', 
        au          => 'audio/basic', 
        aifc        => 'audio/x-aiff', 
        aif         => 'audio/x-aiff', 
        aiff        => 'audio/x-aiff',
        wav         => 'audio/x-wav', 
        gif         => 'image/gif', 
        ief         => 'image/ief', 
        jfif        => 'image/jpeg', 
        'jfif-tbnl' => 'image/jpeg', 
        jpe         => 'image/jpeg', 
        jpg         => 'image/jpeg', 
        jpeg        => 'image/jpeg', 
        tif         => 'image/tiff', 
        tiff        => 'image/tiff', 
        fpx         => 'image/vnd.fpx', 
        fpix        => 'image/vnd.fpx', 
        ras         => 'image/x-cmu-rast', 
        pnm         => 'image/x-portable-anymap',
        pbn         => 'image/x-portable-bitmap', 
        pgm         => 'image/x-portable-graymap', 
        ppm         => 'image/x-portable-pixmap', 
        rgb         => 'image/x-rgb',
        xbm         => 'image/x-xbitmap', 
        xpm         => 'image/x-xbitmap', 
        xwd         => 'image/x-xwindowdump', 
        png         => 'image/png', 
        css         => 'text/css',
        htm         => 'text/html',
        html        => 'text/html', 
        shtml       => 'text/html', 
        text        => 'text/plain', 
        c           => 'text/plain', 
        cc          => 'text/plain', 
        'c++'       => 'text/plain',
        h           => 'text/plain', 
        pl          => 'text/plain', 
        pm          => 'text/plain', 
        cgi         => 'text/plain', 
        txt         => 'text/plain', 
        java        => 'text/plain', 
        el          => 'text/plain',
        tsv         => 'text/tab-separated-values', 
        etx         => 'text/x-setext', 
        mpg         => 'video/mpeg', 
        mpe         => 'video/mpeg', 
        mpeg        => 'video/mpeg',
        mov         => 'video/quicktime', 
        qt          => 'video/quicktime', 
        avi         => 'application/x-troff-msvideo', 
        movie       => 'video/x-sgi-movie',
        mv          => 'video/x-sgi-movie', 
        mime        => 'message/rfc822', 
        xml         => 'application/xml'
    ) unless keys %CONTENT_EXT;

    %CONTENT_EXT;
}
END_OF_SUB

$COMPILE{mime_type} = __LINE__ . <<'END_OF_SUB';
sub mime_type {
# -------------------------------------------------------------------
# Map content-type to image file
#
    %MIME_TYPE = (
        'text/css'                      => 'html.gif',
        'text/html'                     => 'html.gif',
        'text/plain'                    => 'txt.gif',
        'application/pdf'               => 'pdf.gif',
        'application/dvi'               => 'dvi.gif',
        'application/postscript'        => 'postscript.gif',
        'application/x-tex'             => 'tex.gif',
        'application/x-texinfo'         => 'tex.gif',
        'application/gtar'              => 'tar.gif',
        'application/x-tar'             => 'tar.gif',
        'application/x-ustar'           => 'tar.gif',
        'application/zip'               => 'tgz.gif',
        'message/rfc822'                => 'email.gif',
        'message/external-body'         => 'email.gif',
        'multipart/alternative'         => 'email.gif',
        'multipart/appledouble'         => 'email.gif',
        'multipart/digest'              => 'email.gif',
        'multipart/mixed'               => 'email.gif',
        'multipart/voice-message'       => 'sound.gif',
        'audio/basic'                   => 'sound.gif',
        'audio/x-aiff'                  => 'sound.gif',
        'audio/x-wav'                   => 'sound.gif',
        'image/gif'                     => 'image.gif',
        'image/ief'                     => 'image.gif',
        'image/jpeg'                    => 'image.gif',
        'image/tiff'                    => 'image.gif',
        'image/vnd.fpx'                 => 'image.gif',
        'image/x-cmu-rast'              => 'image.gif',
        'image/x-portable-anymap'       => 'image.gif',
        'image/x-portable-bitmap'       => 'image.gif',
        'image/x-portable-graymap'      => 'image.gif',
        'image/x-portable-pixmap'       => 'image.gif',
        'image/x-rgb'                   => 'image.gif',
        'image/x-xbitmap'               => 'image.gif',
        'image/x-xwindowdump'           => 'image.gif',
        'image/png'                     => 'image.gif',
        'image/bmp'                     => 'image.gif',
        'video/mpeg'                    => 'video.gif',
        'video/quicktime'               => 'video.gif',
        'application/x-troff-msvideo'   => 'video.gif',
        'video/x-sgi-movie'             => 'video.gif',
    ) unless keys %MIME_TYPE;

    %MIME_TYPE;
}
END_OF_SUB

1;

__END__

=head1 NAME

GT::MIMETypes - Methods to guess MIME Types of files.

=head1 SYNOPSIS

    use GT::MIMETypes;

    my $file = '/foo/bar/abc.doc';
    my $mime = GT::MIMETypes::guess_type($file);
    my $img  = GT::MIMETypes::guess_image($file);

=head1 DESCRIPTION

GT::MIMETypes provides two simple methods C and C.
They take either a filename or a hash reference.

C returns the MIME type of the file, and guess_image returns an
image name that represents the file.

=head1 COPYRIGHT

Copyright (c) 2000 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: MIMETypes.pm,v 1.13 2002/04/07 03:35:35 jagerman Exp $

=cut

private/lib/GT/File/0040755000076400010020000000000007477023142013001 5ustar  alexcvsprivate/lib/GT/File/Tools.pm0100644000076400010020000011313607473503404014441 0ustar  alexcvs# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::File::Tools
#   Author : Scott Beck
#   $Id: Tools.pm,v 1.38 2002/05/24 18:31:32 alex Exp $
#
# Copyright (c) 2000 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: Basic file tools
#

package GT::File::Tools;
# ==================================================================

use strict;
use vars qw/
    $VERSION
    @EXPORT_OK
    %EXPORT_TAGS
    $MAX_DEPTH
    $GLOBBING
    $ERRORS
    $MAX_READ
    $DEBUG
    $NO_CHDIR
/;

use bases 'GT::Base' => '';

use Cwd;
use Exporter;
use GT::AutoLoader;
$VERSION = sprintf "%d.%03d", q$Revision: 1.38 $ =~ /(\d+)\.(\d+)/;

# Exporter variables
@EXPORT_OK = qw/
    copy
    move
    del
    deldir
    find
    rmkdir
    parsefile
    filename
    dirname
    expand 
/;
%EXPORT_TAGS = ( all => \@EXPORT_OK );
*import = \&Exporter::import;

# Options
$MAX_DEPTH = 1000;
$GLOBBING = 0;
$NO_CHDIR = 0;
$MAX_READ = 1024 * 64;
$DEBUG = 0;
$ERRORS = {
    UNLINK    => "Could not unlink %s; Reason: %s",
    RMDIR     => "Could not rmdir %s; Reason: %s",
    MOVE      => "Could not move %s to %s; Reason: %s",
    RENAME    => "Could not rename %s to %s; Reason: %s",
    SYMLINK   => "Could not symlink %s to %s; Reason: %s",
    NOTAFILE  => "File to copy, move, or del (%s) is not a regular file",
    NOTADIR   => "Path passed to find (%s) is not a directory",
    TOODEEP   => "Recursive find surpassed max depth. Last path was %s",
    RECURSIVE => "Circular symlinks detected",
    OPENDIR   => "Could not open directory %s; Reason: %s",
    READOPEN  => "Could not open %s for reading; Reason: %s",
    WRITEOPEN => "Could not open %s for writing; Reason: %s"
};

$COMPILE{move} = __LINE__ . <<'END_OF_SUB';
sub move {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';

    $class->fatal( BADARGS => "No arguments passed to move()" )
        unless @_;

    my $opts = pop if ref $_[$#_] eq 'HASH';
    $opts = {} unless defined $opts;

    my $to = pop;
    $class->fatal( BADARGS => "No place to move files to specified for move()" )
        unless defined $to;

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my @files = @_;
    @files = expand( @files ) if $globbing;

    $class->fatal( BADARGS => "No files to move" )
        unless @files;

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    my %seen;
    for my $from_file ( @files ) {
        my $to_file = $to;
        if ( !-d $to and $seen{$to}++ ) {
            $class->fatal(
                BADARGS => "Trying to move multiple files into one file"
            );
        }
        if ( -d $from_file ) {
            $class->debug( "movedir $from_file, $to_file" ) if $DEBUG > 1;
            movedir(
                $from_file, $to_file,
                {
                    error_handler   => $error_handler,
                    max_depth       => $max_depth
                }
            ) or return;
            next;
        }
        if ( -d $to_file ) {
            $to_file = $to . '/' . filename( $from_file );
        }
        if ( -l $from_file ) {
            my ( $link ) = _fix_symlink( $from_file );
            if ( !symlink $link, $to_file ) {
                $error_handler->( SYMLINK => $from_file, $to_file, "$!" )
                    or return;
            }
            if ( !unlink $from_file ) {
                $error_handler->( UNLINK => $from_file, "$!" )
                    or return;
            }
            next;
        }
        my ( $to_size_before, $to_mtime_before ) = ( stat( $to_file ) )[7, 9];
        my $from_size = -s $from_file;
        $class->debug( "rename $from_file, $to_file" ) if $DEBUG > 1;
        next if rename $from_file, $to_file;
        my $err = "$!";
        my $errno = 0+$!;

# Under NFS rename can work but still return an error, check for that
        my ( $to_size_after, $to_mtime_after ) = ( stat( $to_file ) )[7, 9];
        if ( defined $from_size and -e $from_file ) {
            if (
                defined $to_mtime_before and
                ( 
                    $to_size_before != $to_size_after or
                    $to_mtime_before != $to_mtime_after
                ) and
                $to_size_after == $from_size
            )
            {
                $class->debug( "rename over NFS worked" ) if $DEBUG > 1;
                next;
            }
        }

        $class->debug( "copy $from_file, $to_file" ) if $DEBUG > 1;
        next if copy( $from_file, $to_file,
            {
                preserve_all    => 1,
                max_depth       => $max_depth,
                error_handler   => $error_handler
            }
        ) and unlink $from_file;

# Remove if a particial copy happened
        if (
            !defined( $to_mtime_before )        or
            $to_mtime_before != $to_mtime_after or
            $to_size_before != $to_size_after
        )
        {
            unlink $to_file;
        }
        $error_handler->( RENAME => $from_file, $to_file, $err, $errno )
            or return;
    }
    return 1;
}
END_OF_SUB

$COMPILE{movedir} = __LINE__ . <<'END_OF_SUB';
sub movedir {
# ----------------------------------------------------------------------------
    my ( $from, $to, $opts ) = @_;
    my $class = 'GT::File::Tools';

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    $from .= '/' unless $from =~ m,/\Z,;
    $to .= '/' unless $to =~ m,/\Z,;

# To move a directory inside an already existing directory
    $to .= filename( $from ) if -d $to;

# Try the easy way out first
    return 1 if rename $from, $to;

    my $cwd;
    if ( ( parsefile( $from ) )[2] ) {
        $cwd = getcwd;
        $from = "$cwd/$from";
    }
    if ( ( parsefile( $to ) )[2] ) {
        $cwd ||= getcwd;
        $to = "$cwd/$to";
    }

    return find(
        $from,
        sub {
            my ( $path ) = @_;
            if ( -l $path ) {
                $path .= '/' if ( -d _ and $path !~ m,/\Z, );
                my ( $link, $relative ) = _fix_symlink( $path );
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "link $link, $new_path" ) if $DEBUG > 1;
                unless (-l $new_path) {
                    symlink $link, $new_path
                        or $error_handler->( SYMLINK =>  $link, $new_path, "$!" )
                        or return;
                }
                _preserve( $path, $new_path,
                    set_owner => 1,
                    set_time  => 1
                );
                unlink $path
                    or $error_handler->( UNLINK =>  $path, "$!" )
                    or return;
                return 1;
            }
            elsif ( -d $path ) {
                $path .= '/' unless $path =~ m,/\Z,;
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "mkdir $new_path" ) if $DEBUG > 1;
                unless (-d $new_path) {
                    mkdir $new_path, 0777
                        or $error_handler->( MKDIR =>  $new_path, "$!" )
                        or return;
                }
                _preserve( $path, $new_path,
                    set_perms => 1,
                    set_owner => 1,
                    set_time  => 1
                );
                rmdir $path
                    or $error_handler->( RMDIR => $path, "$!" )
                    or return;
            }
            elsif ( -f _ ) {
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "move $path, $new_path" ) if $DEBUG > 1;
                move( $path, $new_path,
                    {
                        error_handler   => $error_handler,
                        max_depth       => $max_depth,
                    }
                )   or $error_handler->( MOVE => $path, $new_path, "$!" )
                    or return;
            }
            else {
                $error_handler->( NOTAFILE => $path ) or return;
            }
            return 1;
        },
        {
            dirs_first      => 1,
            error_handler   => $error_handler,
            max_depth       => $max_depth,
        }
    );
}
END_OF_SUB

$COMPILE{del} = __LINE__ . <<'END_OF_SUB';
sub del {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';
    my $opts = pop if ref $_[$#_] eq 'HASH';
    $opts = {} unless defined $opts;

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 } unless $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my @files = @_;
    @files = expand( @files ) if $globbing;

    $class->fatal( BADARGS => "No directories to delete" )
        unless @files;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    for my $path ( @files ) {
        if ( -l $path ) {
            $class->debug( "unlink $path" ) if $DEBUG > 1;
            unlink $path
                or $error_handler->( UNLINK => $path, "$!" )
                or return;
        }
        elsif ( -d $path ) {
            $error_handler->( NOTAFILE => $path )
                or return;
        }
        else {
            unlink $path
                or $error_handler->( UNLINK => $path, "$!" )
                or return;
        }
    }
    return 1;
}
END_OF_SUB

$COMPILE{deldir} = __LINE__ . <<'END_OF_SUB';
sub deldir {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';
    my $opts = pop if ref $_[$#_] eq 'HASH';
    $opts = {} unless defined $opts;

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 } unless $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my @dirs = @_;
    @dirs = expand( @dirs ) if $globbing;

    $class->fatal( BADARGS => "No directories to delete" )
        unless @dirs;

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    for my $dir ( @dirs ) {
        $class->fatal( BADARGS => "$dir is not a directory" )
            if -e $dir and !-d _;
        next if !-e _ and !-l $dir;


        $dir .= '/' unless $dir =~ m,/\Z,;

# Try the easy way out first
        next if rmdir $dir;

        find(
            $dir,
            sub {
                my ( $path ) = @_;
                if ( -l $path ) {
                    $class->debug( "unlink $path" ) if $DEBUG > 1;
                    unlink $path
                        or $error_handler->( UNLINK => $path, "$!" )
                        or return;
                }
                elsif ( -d $path ) {
                    $class->debug( "rmdir $path" ) if $DEBUG > 1;
                    rmdir $path
                        or $error_handler->( RMDIR => $path, "$!" )
                        or return;
                }
                else {
                    $class->debug( "unlink $path" ) if $DEBUG > 1;
                    unlink $path
                        or $error_handler->( UNLINK => $path, "$!" )
                        or return;
                }
                return 1;
            },
            {
                dirs_first      => 0,
                error_handler   => $error_handler,
                max_depth       => $max_depth,
            }
        );
    }
    return 1;
}
END_OF_SUB

$COMPILE{copy} = __LINE__ . <<'END_OF_SUB';
sub copy {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';

    $class->fatal( BADARGS => "No arguments passed to move()" )
        unless @_;

    my $opts = pop if ref $_[$#_] eq 'HASH';
    $opts = {} unless defined $opts;
    my $to = pop;
    $class->fatal( BADARGS => "No place to move files to specified for move()" )
        unless defined $to;

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my @files = @_;
    @files = expand( @files ) if $globbing;

    $class->fatal( BADARGS => "No files to move" )
        unless @files;

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my %preserve_opts = (set_perms => 1);
    if ( delete $opts->{preserve_all} ) {
        @preserve_opts{qw/set_perms set_owner set_time/} = ( 1, 1 ,1 );
    }
    else {
        $preserve_opts{set_perms} = delete $opts->{set_perms} if defined $opts->{set_perms};
        @preserve_opts{qw/set_owner set_time/} =
        (
            delete $opts->{set_owner},
            delete $opts->{set_time}
        );
    }

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    my %seen;
    for my $from_file ( @files ) {
        my $to_file = $to;
        if ( !-d $to_file and $seen{$to_file}++ ) {
            $class->fatal(
                BADARGS => "Trying to copy multiple files into one file $from_file => $to"
            );
        }
        if ( -d $from_file ) {
            $class->debug( "copydir $from_file, $to_file" ) if $DEBUG > 1;
            copydir( $from_file, $to_file, {
                error_handler   => $error_handler,
                max_depth       => $max_depth,
                %preserve_opts
            });
            next;
        }
        if ( -d $to_file ) {
            $to_file = $to . '/' . filename( $from_file );
        }
        if ( -l $from_file ) {
            my ( $link ) = _fix_symlink( $from_file );
            if ( !symlink $link, $to_file ) {
                $error_handler->( SYMLINK => $from_file, $to_file, "$!" )
                    or return;
            }
            next;
        }

        local( *FROM, *TO );
        $class->debug( "open $from_file" ) if $DEBUG > 1;
        unless ( open FROM, "< $from_file" ) {
            $error_handler->( READOPEN => $from_file, "$!" ) or return;
            next;
        }
        $class->debug( "open $to_file" ) if $DEBUG > 1;
        unless ( open TO, "> $to_file" ) {
            $error_handler->( WRITEOPEN => $to_file, "$!" ) or return;
            next;
        }
        binmode FROM or $class->fatal( BINMODE => "$!" );
        binmode TO or $class->fatal( BINMODE => "$!" );
        my $size = -s FROM;
        $size = $MAX_READ if $size > $MAX_READ;

        while () {
            my ( $ret, $buf );
            $ret = sysread FROM, $buf, $size;
            $class->fatal( READ => "$!" )
                unless defined $ret;
            last unless $ret;
            $ret = syswrite TO, $buf, length $buf;
            $class->fatal( WRITE => "$!" )
                unless defined $ret;
        }

        close FROM;
        close TO;

# Set permissions, mtime, and owner
        _preserve( $from_file, $to_file, %preserve_opts );

    }
    return 1;
}
END_OF_SUB

$COMPILE{copydir} = __LINE__ . <<'END_OF_SUB';
sub copydir {
# ----------------------------------------------------------------------------
    my ( $from, $to, $opts ) = @_;
    my $class = 'GT::File::Tools';

    $class->fatal( BADARGS => "No from directory specified" )
        unless defined $from;
    $class->fatal( BADARGS => "From file specified must be a directory" )
        unless -d $from;
    $class->fatal( BADARGS => "No to directory specified" )
        unless defined $from;
    my $error_handler = delete $opts->{error_handler};

    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my %preserve_opts = (set_perms => 1);
    if ( delete $opts->{preserve_all} ) {
        @preserve_opts{qw/set_perms set_owner set_time/} = ( 1, 1 ,1 );
    }
    else {
        $preserve_opts{set_perms} = delete $opts->{set_perms} if defined $opts->{set_perms};
        @preserve_opts{qw/set_owner set_time/} =
        (
            delete $opts->{set_owner},
            delete $opts->{set_time}
        );
    }

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    $from .= '/' unless $from =~ m,/\Z,;
    $to .= '/' unless $to =~ m,/\Z,;

# To move a directory inside an already existing directory
    $to .= filename( $from ) if -d $to;

    my $cwd;
    if ( ( parsefile( $from ) )[2] ) {
        $cwd = getcwd;
        $from = "$cwd/$from";
    }
    if ( ( parsefile( $to ) )[2] ) {
        $cwd ||= getcwd;
        $to = "$cwd/$to";
    }

    return find(
        $from,
        sub {
            my ( $path ) = @_;
            if ( -l $path ) {
                $path .= '/' if ( -d _ and $path !~ m,/\Z, );
                my ( $link, $relative ) = _fix_symlink( $path );
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "link $link, $new_path" ) if $DEBUG > 1;
                unless (-l $new_path) {
                    symlink $link, $new_path
                        or $error_handler->( SYMLINK =>  $link, $new_path, "$!" )
                        or return;
                }
                _preserve( $path, $new_path, %preserve_opts );
                return 1;
            }
            elsif ( -d $path ) {
                $path .= '/' unless $path =~ m,/\Z,;
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "mkdir $new_path" ) if $DEBUG > 1;
                unless (-d $new_path) {
                    mkdir $new_path, 0777
                        or $error_handler->( MKDIR =>  $new_path, "$!" )
                        or return;
                }
                _preserve( $path, $new_path, %preserve_opts );
            }
            elsif ( -f $path ) {
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "copy $path, $new_path" ) if $DEBUG > 1;
                copy( $path, $new_path,
                    {
                        %preserve_opts,
                        error_handler   => $error_handler,
                        max_depth       => $max_depth,
                    }
                )
                    or $error_handler->( MOVE => $path, $new_path, "$GT::File::Tools::error" )
                    or return;
# copy() will handle setting permission and such
            }
            else {
                $error_handler->( NOTAFILE => $path )
                    or return;
            }
            return 1;
        }, 
        {
            dirs_first      => 1,
            error_handler   => $error_handler,
            max_depth       => $max_depth,
        }
    );
}
END_OF_SUB

$COMPILE{filename} = __LINE__ . <<'END_OF_SUB';
sub filename {
# ----------------------------------------------------------------------------
    return ( parsefile( $_[0] ) )[1];
}
END_OF_SUB

$COMPILE{dirname} = __LINE__ . <<'END_OF_SUB';
sub dirname {
# ----------------------------------------------------------------------------
    return ( parsefile( $_[0] ) )[0];
}
END_OF_SUB

$COMPILE{parsefile} = __LINE__ . <<'END_OF_SUB';
sub parsefile {
# ----------------------------------------------------------------------------
    my ( $in ) = @_;
    my ( @path, @normal, $relative, $win32 );
    if ( $^O eq 'MSWin32' ) {
        $win32 = $1 if $in =~ s/\A(\w:)//;
        @path = split m|[/\\]|, $in;
        $relative = 1 unless $in =~ m,\A[/\\],;
    }
    else {
        @path = split m|/|, $in;
        $relative = 1 unless $in =~ m,\A/,;
    }
    my $start = 0;
    for ( @path ) {
        if ( $_ eq '.' or !length ) { next }
        elsif ( $_ eq '..' ) { $start-- }
        else { $start++ }

        if ( !$relative and $start < 0 and $_ eq '..' ) { next }
        elsif ( $start < 0 and $_ eq '..' ) { push @normal, ".." }
        elsif ( $start >= 0 and $_ eq '..' ) { pop @normal }
        else { push @normal, $_ }
    }
    my $file = pop @normal;
    my $new_path = join "/", @normal;
    $new_path = $relative ? "./$new_path" : "/$new_path";
    $new_path = "$win32$new_path" if $win32;

    return ( $new_path, $file, $relative );
}
END_OF_SUB


$COMPILE{rmkdir} = __LINE__ . <<'END_OF_SUB';
sub rmkdir {
    my ($full_path, $perms) = @_;
    my ($path, $target, $is_relative) = parsefile($full_path);
    GT::File::Tools->fatal(BADARGS => 'You can not pass a relative path to rmkdir')
        if $is_relative;
    my @tomake = (split(m|/|, $path), $target);
    my $cwd = getcwd;
    my $err = sub {
        my $bang = 0+$!;
        chdir $cwd;
        $! = $bang;
        return;
    };
    chdir '/' or return $err->();
    for (@tomake) {
        next unless length;
        if (!-d $_) {
            mkdir $_, 0777 or return $err->();
            if (defined $perms) {
                chmod $perms, $_ or return $err->();
            }
        }
        chdir $_ or return $err->();
    }
    chdir $cwd or return $err->();
    return 1;
}
END_OF_SUB

$COMPILE{find} = __LINE__ . <<'END_OF_SUB';
sub find {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';

    $class->fatal( BADARGS => "No arguments passed to find()" )
        unless @_;

    my $opts = pop if ref $_[$#_] eq 'HASH';
    $opts = {} unless defined $opts;
    my $callback = pop;

    $class->fatal(
        BADARGS => "Argument after files list must be a code reference"
    ) unless ref $callback eq 'CODE';

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my @files = @_;
    @files = expand( @files ) if $globbing;

    $class->fatal( BADARGS => "No files to find" )
        unless @files;

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $no_chdir = delete $opts->{no_chdir};
    $no_chdir = $NO_CHDIR unless defined $no_chdir;

    my $dirs_first = delete $opts->{dirs_first};
    $dirs_first = 1 unless defined $dirs_first;

    my $files_only = delete $opts->{files_only};
    $files_only = 0 unless defined $files_only;

    my $dirs_only = delete $opts->{dirs_only};
    $dirs_only = 0 unless defined $dirs_only;

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "You may only specify one of files_only or dirs_only"
    ) if $files_only and $dirs_only;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    for my $path ( @files ) {
        next unless -e $path;

        unless ( -d _ ) {
            $error_handler->( NOTADIR => $path ) or return;
            next;
        }

        my $relative = ( parsefile( $path ) )[2];
        my $cwd;
        if ( !$no_chdir or $relative ) {
            $cwd = getcwd;
        }
        if ( $relative ) {
            $path = "$cwd/$path";
        }
        $class->debug( "find $path" ) if $DEBUG > 1;
        eval {
            _find( $path, $callback, {
                error_handler   => $error_handler,
                dirs_first      => $dirs_first,
                files_only      => $files_only,
                max_depth       => $max_depth,
                no_chdir        => $no_chdir,
                dirs_only       => $dirs_only
            }) or do {
                chdir $cwd;
                return;
            };
        };
        chdir $cwd unless $no_chdir;
        die "$@\n" if $@;
    }
    return 1;
}
END_OF_SUB

$COMPILE{_find} = __LINE__ . <<'END_OF_SUB';
sub _find {
# ----------------------------------------------------------------------------
# This is so we can initialize from variable and cleanup in the main find
# function.
#
    my ( $path, $callback, $opts ) = @_;
    my $error_handler = $opts->{error_handler};
    local *DIR;
    if ( $opts->{dirs_first} and !$opts->{files_only} ) {
        $callback->( $path ) or return;
    }
    my $refs = 0;
    my $depth = 0;
    my $opened;
    if ( $opts->{no_chdir} ) {
        $opened = opendir DIR, $path;
    }
    else {
        if ( chdir $path ) {
            $opened = opendir DIR, ".";
        }
        else {
            $error_handler->( CHDIR => $path )
                or return;
        }
    }
    if ( $opened ) {
        my @files =
            map { s,/\Z,,; $opts->{no_chdir} ? "$path/$_" : $_ }
            grep { $_ ne '.' and $_ ne '..' } readdir DIR;
        closedir DIR;
        for ( my $i = 0; $i < @files; $i++ ) {
            my $file = $files[$i];
            if ( ref $file ) {
                if ( !$opts->{dirs_first} and !$opts->{files_only} ) {
                    $callback->( $$file ) or return;
                }
                $depth-- if $opts->{max_depth};
                unless ( $opts->{no_chdir} ) {
                    chdir "..";
                    substr( $path, rindex($path, "/") ) = ""
                        unless $opts->{no_chdir};
                }
                next;
            }

            if ( $opts->{max_depth} and $depth > $opts->{max_depth} ) {
                GT::File::Tools->fatal( 'TOODEEP' );
            }
            my $is_sym = -l $file;
            my $is_dir = -d $file;
            if ( $opts->{dirs_only} ) {
                next unless $is_dir;
            }
            if ($is_sym) {
                $callback->(  $opts->{no_chdir} ? $file : "$path/$file" ) or return;
            }
            elsif ( $is_dir ) {
                next unless -e _;
                local *DIR;
                $depth++;
                my @new_files;
                if ( $opts->{no_chdir} ) {
                    if ( opendir DIR, $file ) {
                        @new_files =
                            map { s,/\Z,,; $opts->{no_chdir} ? "$file/$_" : $_ }
                            grep { $_ ne '.' and $_ ne '..' } readdir DIR;
                        closedir DIR;
                    }
                    else {
                        $error_handler->( OPENDIR => $file ) or return;
                    }
                }
                else {
                    my $opened;
                    if ( chdir $file ) {
                        $opened = opendir DIR, ".";
                    }
                    else {
                        $error_handler->( CHDIR => $file )
                            or return;
                    }
                    if ( $opened ) {
                        @new_files = map { s,/\Z,,; $_ } grep { $_ ne '.' and $_ ne '..' } readdir DIR;
                        closedir DIR;
                    }
                    else {
                        $error_handler->( OPENDIR => $file ) or return;
                    }
                    $path .= '/' . $file;
                }
                if ( $opts->{dirs_first} and !$opts->{files_only} ) {
                    $callback->( $opts->{no_chdir} ? $file : $path ) or return;
                }
                splice @files, $i + 1, 0, @new_files, ( $opts->{no_chdir} ? \$file : \$path );
            }
            else {
                next unless -e _;
                $callback->( $opts->{no_chdir} ? $file : "$path/$file" ) or return;
            }
        }
    }
    else {
        $error_handler->( OPENDIR => $path ) or return;
    }
    if ( !$opts->{dirs_first} and !$opts->{files_only} ) {
        $callback->( $path ) or return;
    }
    return 1;
}
END_OF_SUB

$COMPILE{_fix_symlink} = __LINE__ . <<'END_OF_SUB';
sub _fix_symlink {
# ----------------------------------------------------------------------------
# Tries to get the full path to what a symlink is pointing to. Returns the
# path (full or relative) and a value that is true if the path is relative and
# false otherwise.
#
    my ( $path ) = @_;
    my $link = readlink $path;
    my ( $relative1, $relative2 );
    ( undef, undef, $relative1 ) = parsefile( $link );
    ( undef, undef, $relative2 ) = parsefile( $path );
    if ( $relative1 and !$relative2 ) {
        $relative1 = 0;
        $link = dirname( $path ) . '/' . $link;
    }
    return ( $link, $relative1 );
}
END_OF_SUB

$COMPILE{_preserve} = __LINE__ . <<'END_OF_SUB';
sub _preserve {
# ----------------------------------------------------------------------------
# Set permissions, owner, mtime given file from, file to, and options:
#       set_time
#       set_owner
#       set_perms
#
    my ( $from, $to, %opts ) = @_;
    my $class = 'GT::File::Tools';

    my ( $mode, $uid, $gid, $mtime );
    if ( $opts{set_time} or $opts{set_owner} or $opts{set_perms} ) {
        ( $mode, $uid, $gid, $mtime ) = (stat($from))[2, 4, 5, 9];
    }
    if ( $opts{set_time} ) {
        utime time, $mtime, $to;
    }

    if ( $opts{set_owner} ) {
        chown $uid, $gid, $to
            if ( $> == 0 and $^O ne "MaxOS" and $^O ne "MSWin32" );
    }

    if ( $opts{set_perms} and !-l $to ) {
        chmod $mode, $to or return $class->warn( 'CHMOD', $to, "$!" );
    }
}
END_OF_SUB

$COMPILE{expand} = __LINE__ . <<'END_OF_SUB';
sub expand {
# ----------------------------------------------------------------------------
# Implement globbing for files. Perl's glob function has issues.
#
    my $class = 'GT::File::Tools';
    my ( @files ) = @_;
    my (@ret, $cwd);
    for ( @files ) {
        my ( $dirname, $filename, $relative ) = parsefile( $_ );
        if ($relative) {
            $cwd ||= getcwd;
            ($dirname, $filename) = parsefile( "$cwd/$_" );
        }
        if (
            index( $filename, '*' ) == -1 and
            index( $filename, '?' ) == -1
        )
        {
            push @ret, "$dirname/$filename";
            next;
        }
        $filename = quotemeta $filename;
        $filename =~ s[(^|\G|[^\\])((?:\\{4})*)\\(\\\\)?(\\(?!\\)|[?*])]{
            $1 . ('\\' x (length($2) / 2)) . ($3 ? "\\$4" : $4 eq '*' ? '.*' : $4 eq '?' ? '.' : '\\')
        }eg;
        local *DIR;
        opendir DIR, $dirname
            or $class->fatal( OPENDIR => $dirname, "$!" );
        push @ret, map "$dirname/$_", grep  { /\A$filename\Z/ and $_ ne '.' and $_ ne '..' } readdir DIR;
        closedir DIR;
    }
    return @ret;
}
END_OF_SUB

1;

__END__

=head1 NAME

GT::File::Tools - Export tools for dealing with files

=head1 SYNOPSIS

    use GT::File::Tools qw/:all/;
    
    # Find all files in a users home directory.
    find "/home/user", sub { print shift };
    
    # Rename a file1 to file2.
    move "file1", "file2";

    # Remove a list of files.
    del @files;

    # Remove a users home directory
    deldir "/home/foo";

    # Copy a file
    copy "file1", "file2";

    # Recursively copy a directory.
    copy "/home/user", "/home/user.bak";

    # Recursively make a directory.
    rmkdir "/home/user/www/cgi-bin", 0755;

    # Parse a filename into directory, file and is_relative components
    my ($dir, $file, $is_rel) = parsefile("/home/foo/file.txt");

    # Get the file portion of a filename
    my $file = filename("/home/foo/file.txt");

    # Get the directory portion of a filename.
    my $dir = dirname("/home/foo/file.txt");

    # Use shell like expansion to get a list of absolute files.
    my @src = expand("*.c", "*.h");

=head1 DESCRIPTION

GT::File::Tools is designed to export requested functions into your namespace.
These function perform various file operations.

=head1 FUNCTIONS

GT::File::Tools exports functions to your namespace. Here is a list of the
functions you can request to be exported.

=head2 find

C takes three parameters: directory to search in, callback to run for
each file and/or directory found, and a hash ref of options. B: this is
the opposite order of File::Find's find() function! The following options
can be passed set:

=over 4

=item globbing

Expand filenames in the same way as the unix shell:

    find("/home/a*", sub { print shift; }, { globbing => 1 });

would fine all home directories starting with the letter a. This option is 
off by default.

=item error_handler

A code ref that is run whenever find encounters an error. If the callback 
returns 0, find will stop immediately, otherwise find will continue 
searching (default).

=item no_chdir

By default, find will chdir into the directories it is searching as
this results in a dramatic performance improvement. Upon completion, find
will chdir back to the original directory. This behavior is on by default.

=item dirs_first

This option controls the order find traverses. It defaults on, and means 
find will go down directories first before looking at files. This is 
essential for recursively deleting a directory.

=item files_only

This option tells find to run the callback only for each file found
and not for each directory. Off by default.

=item dirs_only

This option tells find to run the callback only for each directory found
and not for each file. Off by default.

=item max_depth

Defaults to 1000, this option controls how deep a directory structure find
will traverse. Meant mainly as a safety, and should not need to be adjusted.

=back

=head2 move

C has the same syntax as the system mv command:

    move 'file', 'file2';
    move 'file1', 'file2', 'dir';
    move 'file1', 'file2', 'dir3', 'dir';
    move '*.c', 'dir', { globbing => 1 };

The only difference is the last argument can be a hash ref of options. The 
following options are allowed:

=over 4

=item globbing 

=item error_handler

=item max_depth

=back

=head2 del

C has the same syntax as the rm system command, but it can not remove
directories. Use C below to recursively remove files.

    del 'file1';
    del '*.c', { globbing => 1 };
    del 'a', 'b', 'c';

It takes a list of files or directories to delete, and an optional hash ref 
of options. The following options are allowed:

=over 4

=item error_handler

=item globbing

=back

=head2 deldir

C is similiar to C, but allows recursive deletes of directories:

    deldir 'file1';
    deldir 'dir11', 'dir2', 'dir3';
    deldir '/home/a*', { globbing => 1 };

It takes a list of files and/or directories to remove, and an optional hash ref
of options. The following options are allowed:

=over 4

=item error_handler

=item globbing

=item max_depth

=back

=head2 copy

C is similiar to the system cp command:

    copy 'file1', 'file2';
    copy 'file1', 'file2', 'file3', 'dir1';
    copy '*.c', '/usr/local/src', { globbing => 1 };
    copy 

It copies a source file to a destination file or directory. You can also 
specify multiple source files, and copy them into a single directory. The 
last argument should be a hash ref of options:

=over 4

=item set_perms

This option will preserve permissions. i.e.: if the original file is set 755,
the copy will also be set 755. It defaults on.

=item set_owner

This option will preserver file ownership. Note: you must be root to be able
to change ownerhsip of a file. This defaults off.

=item set_time

This option will preserve file modification time.

=item preserve_all

This option sets set_perms, set_owner and set_time on.

=item error_handler

=item globbing

=item max_depth

=back

=head2 rmkdir

C recursively makes a directory. It takes the same arguments as 
perl's mkdir():

    rmkdir("/home/alex/create/these/dirs", 0755) or die "Can't rmkdir: $!";

=head2 parsefile

This function takes any type of filename (relative, fullpath, etc) and 
returns the inputs directory, file, and whether it is a relative path or
not. For example:

    my ($directory, $file, $is_relative) = parsefile("../foo/bar.txt");

=head2 dirname

Returns the directory portion of a filename.

=head2 filename

Returns the file portion of a filename.

=head2 expand

Uses shell like expansion to expand a list of filenames to full paths. For 
example:

    my @source   = expand("*.c", "*.h");
    my @homedirs = expand("/home/*");

If you pass in relative paths, expand always returns absolute paths of 
expanded files. B: this does not actually go to the shell.

=head1 SEE ALSO

This module depends on perl's Cwd module for getting the current working
directory. It also uses GT::AutoLoader to load on demand functions.

=head1 MAINTAINER

Scott Beck

=head1 COPYRIGHT

Copyright (c) 2002 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Tools.pm,v 1.38 2002/05/24 18:31:32 alex Exp $

=cut

private/lib/GT/Installer/0040755000076400010020000000000007477023142014057 5ustar  alexcvsprivate/lib/GT/Installer/language.cn0100644000076400010020000003105107461411607016161 0ustar  alexcvs
%GT::Installer::LANG = (
    ERR_REQUIRED   => "%s ťաC",
    ERR_PATH       => "| (%s) btΤW",
    ERR_PATHWRITE  => "LkgJؿ (%s)C]G (%s)",
    ERR_PATHCREATE => "Lkإߥؿ (%s)C]G (%s)",
    ERR_URLFMT     => "(%s) GOT}",
    ERR_FTPFMT     => "(%s) GOT FTP m",
    ERR_EMAILFMT   => "(%s) GOT email",
    ERR_SENDMAIL   => "| (%s) sbtΤWεLk",
    ERR_SMTP       => "(%s) OĪ SMTP DW",
    ERR_PERL      => "V perl | (%s) %s",
    ERR_DIREXISTS => "%s sbtΤWoO@ӥؿALkΦW٫إߥؿ",
    ERR_WRITEOPEN      => "Lk} %s ӼgJơF]G %s",
    ERR_READOPEN      => "Lk} %s ŪXơF]G %s",
    ERR_RENAME => "LkN %s sRW %sF]G %s",
    ERR_MKDIR  => "Lk mkdir %sC]G %s",
    ENTER_REG => 'пJzUX',
    REG_NUM => 'UX',
    ENTER_SENDMAIL => 'пJΨӰeXql sendmail | SMTP DW',
    MAILER => 'Mailer',
    ENTER_PERL => 'пJV perl 5 |',
    PATH_PERL => 'Perl |',
    CREATE_DIRS => 'إߥؿ',
    INSTALL_CURRUPTED => '
install.dat GwlaCнT{zb FTP ɮɡBϥΪO BINARY ҦCΪ̡A
zUYɥiwlaCЦA Gossamer Threads UsɮסC

pGzݭnUAШG 
    http://gossamer-threads.com/scripts/support/
',
   ADMIN_PATH_ERROR => "zJܲ{ admin |",
   INTRO => '
%s Quick Install http://gossamer-threads.com
Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved
Redistribution in part or in whole strictly prohibited.

ԲӸƽаѾ\ LICENSE 
',
    WELCOME => '
wϥ %s ۰ʦw˨tΡCw˵{N| %s Yʧ@B
]wҦɮvBΥT]w perl |C 

Ĥ@BAХJHUơC
ziHbɭJ exit  quit Өw˵{ǡC
',
    IS_UPGRADE => "аݱznisw˩άON{ɯšH",
    ENTER_ADMIN_PATH => "\nпJܲ{ admin |",
    UNARCHIVING => 'Y',
    TAR_OPEN        => "Lk} %sC]G %s",
    TAR_READ        => "q %s ŪXƮɵoͿ~CŪX %s bytesAuŪX %s.",
    TAR_BINMODE     => "Lk binmode %sC]G %s",
    TAR_BADARGS     => "LĤ޼ơ]arguments^ǤJ %sC]G %s",
    TAR_CHECKSUM    => "ѪR tar ɮɵo Checksum ~Co tar ɫܥiOlaɮסC\nYG %s\nChecksumG %s\nɮסG %s\n",
    TAR_NOBODY      => "'%s' does not have a body!",
    TAR_CANTFIND    => "b tar Yɸ̧䤣ɮסG '%s' C",
    TAR_CHMOD       => "Lk chmod %sC]G %s",
    TAR_DIRFILE     => "'%s' sbӥBOɮסCLkإߥؿ",
    TAR_MKDIR       => "Lk mkdir %sC]G %s",
    TAR_RENAME      => "LksRW temp ɡG '%s'  tar  '%s'C]G %s",
    TAR_NOGZIP      => "Bz .tar.gz ɮ׮ɡBݭn Compress::Zlib ҲաC",
    SKIPPING_FILE => "L %s\n",
    OVERWRITTING_FILE => "\L %s ",
    SKIPPING_MATCHED => "bŦXؿ̲L %s \n",
    BACKING_UP_FILE => "s@ %s ƥ\n",
    ERR_OPENTAR => '
Lk} install.datIw˵{ݭnŪɡCнT{ɮצsbBɮv]wTC

~TG 
    %s

pGzݭnUAШG
    http://gossamer-threads.com/scripts/support/
',
    ERR_OPENTAR_UNKNOWN => '
} tar ɮɵoͤF~G
    %s

pGzݭnUAШG
http://gossamer-threads.com/scripts/support/
',
    WE_HAVE_IT => "\nڭ̤w`FҦ\n\n",
    ENTER_STARTS => "\n ENTER ӶiwˡBΫ CTRL-C ",
    NOW_UNARCHIVING => '

w˵{NdzƬ %s iYʧ@CЭ@ߵ...
',
    UPGRADE_DONE => '

߱zIz %s w\ɯŦ %s CwɮפwQC

pGzݭnswˡAХѱz̪UYɤNwɮ׸YC
',
    INSTALL_DONE => '

%s wYʧ@CwɮפwQC
pGzݭnswˡAХѱz̪UYɤYC

ƵGקKNz̪쪺 .tar.gz ɮׯdbzؿI

',
    TELNET_ERR => '~G %s',
    FIRST_SCREEN => '

    
    wϥ <%product%> <%version%>
    
    
    
    
    
    
    
    
    
        
     <%product%>
        w
        
    
          		
    
    
    
    
      
      
    
      

    
      wϥ <%product%>Cw˵{N| <%product%> Yʧ@B
      ]wҦɮvBΥT]w perl |C
        
      <%error%>

      
     

  
    <%message%>
    
    
      
        аݱzn@sw˩άON{ɯšH
    
    
    
    
      sw
      
    
    
    
    
      ɯ
      
    
    
    
    
      ܲ{ admin |]ɯš^G
    
    
    
    
      
    
    
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_FIRST_SCREEN => '

    
    wϥ <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
    
        
     <%product%>
        w
        
    
          		
    
    
    
    
      
      
    
      

    
      wϥ <%product%>Cw˵{N| <%product%> Yʧ@B
      ]wҦɮvBΥT]w perl |CbiU@BeAzDHUơCj쳣wJXzw]ȡA
      ˬd̬O_TC

      <%error%>
      
     

  
    <%upgrade_form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_SECOND_SCREEN_FIRST => '

    
    wϥ <%product%>
    
    

    
    
    
    
        
     <%product%>
        w
        
    
          		
    
    
    
    
      
      
    
      

    
      
      {bN{YAбz@ߵԡAnC
      
    
      
    
          		
    
    

    

    ',
    UPGRADE_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> wYʧ@C

<%install_message%>


    קKNz̪쪺 .tar.gz ɮׯdbzؿI


    pGzDAziHڭ̪䴩QװMD䴩C
<%message%>
    
     
    
    


    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_WARNING => '
    ĵiG бN install.cgi M install.dat qؿCNoɮׯdbo̱Nް_wWü{C',
    INSTALL_REMOVED => '
    wɮפwQCpGzݭnswˡAХѱz̪UYɤYC',

    OVERWRITE => '\L\n',
    BACKUP => 'ƥ',
    SKIP => 'L',
    INSTALL_FIRST_SCREEN => '

    
    wϥ <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
        
     <%product%>
        w
        
    
          		
    
    
    
    
      
      
    
      

    
      wϥ <%product%>Cw˵{N| <%product%>Yʧ@B]wҦɮvB
      ΥT]w perl |C biU@BeAzDHUơCj쳣wJXzw]ȡAˬd̬O_TC

      <%error%>
      
    

  
    <%form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_SECOND_SCREEN_FIRST => '

    
    wϥ <%product%>
    
    

    
    
    
    
        
     <%product%>
        w
        
    
          		
    
    
    
    
      
      
    
      

    
      
     {bN{YCбz@ߵԡAnC
      
    
      
    
          		
    
    

    

    ',
    INSTALL_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> wYʧ@C

<%install_message%>


    קKNz̪쪺 .tar.gz ɮׯdbzؿI


    pGzDAziHڭ̪䴩QװMD䴩C
<%message%>

     

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    CGI_ERROR_SCREEN => '

    
    Error
    
    
    
    
    
    
        
     ~
        
    
          		
    
    
    
    
      
      
    
      

    
      oͿ~G

      <%error%>
      
    
      
    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INVALID_RESPONCE => "\nLĪ^ (%s)\n",
);

private/lib/GT/Installer/language.de0100644000076400010020000003702507461411607016160 0ustar  alexcvs
%GT::Installer::LANG = (
    ERR_REQUIRED   => "%s darf nicht leer sein.",
    ERR_PATH       => "Das Verzeichnis (%s) existiert auf diesem System nicht.",
    ERR_PATHWRITE  => "In das Verzeichnis (%s) kann nicht geschrieben werden. Grund: (%s)",
    ERR_PATHCREATE => "Das Verzeichnis (%s) kann nicht angelegt werden. Grund: (%s)",
    ERR_URLFMT     => "(%s) ist nicht im URL Format.",
    ERR_FTPFMT     => "(%s) ist nicht im FTP-URL Format.",
    ERR_EMAILFMT   => "(%s) ist nicht im Email Format.",
    ERR_SENDMAIL   => "Das Verzeichnis (%s) existiert auf diesem System nicht oder ist nicht ausfhrbar",
    ERR_SMTP       => "(%s) ist keine gltige SMTP-Server Adresse",
    ERR_PERL      => "Das angegebene Perl-Verzeichnis (%s) ist ungltig %s",
    ERR_DIREXISTS => "%s ist kein Verzeichnis, aber existiert bereits. Ein Verzeichnis mit diesem Namen kann nicht angelegt werden.",
    ERR_WRITEOPEN      => "%s kann zum Schreiben nicht geffnet werden; Grund: %s",
    ERR_READOPEN      => "%s kann zum Lesen nicht geffnet werden; Grund: %s",
    ERR_RENAME => "%s kann nicht in %s umbenannt werden; Grund: %s",
    ENTER_REG => 'Geben Sie bitte Ihre Registrierungsnummer an',
    REG_NUM => 'Registrierungsnummer',
    ENTER_SENDMAIL => 'Geben Sie bitte den Pfad von Sendmail oder Ihres SMTP Server an, um Emails zu versenden',
    MAILER => 'Mailer',
    ENTER_PERL => 'Geben Sie bitte das Perl 5 Verzeichnis an',
    PATH_PERL => 'Perl-Verzeichnis',
    CREATE_DIRS => 'Verzeichnisse anlegen',
    INSTALL_CURRUPTED => '
Die Datei Install.dat scheint unvollstndig zu sein. Bitte prfen Sie, ob der FTP-Upload im BINARY Modus durchgefhrt worden ist. Wenn Sie einen ASCII Transfer vorgenommen haben, ist Ihre Installationsdatei beschdigt. Bitte fhren Sie einen neuen Download bei Gossamer Threads Inc. durch.

Wenn Sie Hilfe bentigen, besuchen Sie bitte : 
    http://gossamer-threads.com/scripts/support/
',
   ADMIN_PATH_ERROR => "You must specify the path to the previous install's admin area",
   INTRO => '
%s Schnell-Installation http://gossamer-threads.com
Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved
Redistribution in part or in whole strictly prohibited.

Please see LICENSE file for full details.
',
    WELCOME => '
Willkommen zur automatischen Installation von %s. Dieses Programm wird das Archiv von %s auspacken, alle notwendigen Dateien anlegen und entsprechende Rechte setzen.

Um mit der Installation zu beginnen, geben Sie die folgenden Informationen an. Sie knnen jederzeit den Vorgang mit "exit" oder "quit" abbrechen.
',
    IS_UPGRADE => "Soll ein Upgrade einer vorhandenen Installation durchgefhrt werden",
    ENTER_ADMIN_PATH => "\nBitte geben Sie das Verzeichnis der Administration an",
    UNARCHIVING => 'Dekomprimierung',
    TAR_OPEN        => "%s kann nicht geffnet werden. Grund: %s",
    TAR_READ        => "Beim Lesen der Datei %s ist ein Fehler aufgetreten. Es wurden %s Bytes erwartet, aber nur %s Bytes sind angekommen.",
    TAR_BINMODE     => "%s kann kein Binrmodus sein. Grund: %s",
    TAR_BADARGS     => "Es wurden an %s ungltige Parameter bergeben. Grund: %s",
    TAR_CHECKSUM    => "Checksummen Fehler im TAR-Archiv aufgetreten. In den meisten Fllen ist das TAR-Archiv fehlerhaft.\nHeader: %s\nChecksumme: %s\nDatei: %s\n",
    TAR_NOBODY      => "Die Datei '%s' hat keine Daten!",
    TAR_CANTFIND    => "Die Datei '%s' kann nicht im TAR-Archiv gefunden werden.",
    TAR_CHMOD       => "Der Befehl chmod %s kann nicht durchgefhrt werden. Grund: %s",
    TAR_DIRFILE     => "Die Datei '%s' ist bereits vorhanden. Ein Verzeichnis mit dem gleichen Namen kann nicht erstellt werden!",
    TAR_MKDIR       => "Der Befehl mkdir %s kann nicht durchgefhrt werden. Grund: %s",
    TAR_RENAME      => "Die temporre Datei '%s' kann im TAR-Archiv nicht in '%s' umbenannt werden. Grund: %s",
    TAR_NOGZIP      => "Compress::Zlib Modul ist fr die Verwendung von .tar.gz Dateien notwendig.",
    SKIPPING_FILE => "Datei %s wird bersprungen\n",
    OVERWRITTING_FILE => "Datei %s wird berschrieben",
    SKIPPING_MATCHED => "berspringen von %s im Verzeichnis\n",
    BACKING_UP_FILE => "Backup von %s",
    ERR_OPENTAR => '
Die Datei install.dat kann nicht geffnet werden! Bitte prfen Sie das Vorhandensein im richtigen Verzeichnis und die Dateirechte, um die Datei lesen zu knnen.

Folgender Fehler trat auf: 
    %s

Wenn Sie Hilfe brauchen, besuchen Sie bitte die Seite: 
    http://gossamer-threads.com/scripts/support/
',
    ERR_OPENTAR_UNKNOWN => '
Unbekannter Fhler beim Lesen des TAR-Archivs aufgetreten:
    %s

Wenn Sie Hilfe brauchen, besuchen Sie bitte die Seite: 
    http://gossamer-threads.com/scripts/support/
',
    WE_HAVE_IT => "\nSie haben alle notwendigen Informationen angegeben. Die Installation der Dateien kann beginnen...\n\n",
    ENTER_STARTS => "\nDrcken Sie bitte RETURN, um zu installieren oder STRG-C um abzubrechen.",
    NOW_UNARCHIVING => '

Die Datei %s wird jetzt dekomprimiert. Alle Dateien werden in das richtige Verzeichnis geschrieben. Bitte haben Sie Geduld...
',
    UPGRADE_DONE => '

Gratulation! Ihre Installation von %s wurde auf Version  %s upgedatet. Die Installationsdateien wurden gelscht. 

Wenn Sie die Installation erneut durchfhren wollen, dekomprimieren Sie bitte erneut die Original-Datei.
',
    INSTALL_DONE => '

%s ist nun installiert. Die Installationsdateien wurden gelscht. 

Wenn Sie die Installation erneut durchfhren wollen, dekomprimieren Sie bitte erneut die Original-Datei.

HINWEIS: Bitte lassen Sie Ihre Original-Datei (.tar.gz) nicht in Ihrem
Web-Verzeichnis!

',
    TELNET_ERR => 'Fehler: %s',
    FIRST_SCREEN => '

    
    Willkommen zu <%product%> <%version%>
    
    
    
    
    
    
    
    
    
        
     <%product%>
        Installation
        
    
          		
    
    
    
    
      
      
    
      

    
      Willkommen zu <%product%>. Dieses Programm wird das Archiv von <%product%> auspacken, alle notwendigen Dateien anlegen, entsprechende Rechte setzen
      und das Verzeichnis von Perl eintragen.      
        
      <%error%>

      
     

  
    <%message%>
    
    
      
        Soll ein Upgrade einer vorhandenen Installation durchgefhrt werden?
    
    
    
    
      Neue Installation
      
    
    
    
    
      Upgrade einer vorhandenen Installation
      
    
    
    
    
      Bitte geben Sie das Admin-Verzeichnis der bereits installierten Anwendung an:
    
    
    
    
      
    
    
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_FIRST_SCREEN => '

    
    Willkommen zu <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
    
        
     <%product%>
        Installation
        
    
          		
    
    
    
    
      
      
    
      

    
      Willkommen zu <%product%>. Dieses Programm wird das Archiv von <%product%> auspacken, alle notwendigen Dateien anlegen, entsprechende Rechte setzen
      und das Verzeichnis von Perl eintragen. Um mit dem Upgrade zu beginnen,
      prüfen Sie bitte die folgenden Werte sorgfältig.      

      <%error%>
      
     

  
    <%upgrade_form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_SECOND_SCREEN_FIRST => '

    
    Willkommen zu <%product%>
    
    

    
    
    
    
        
     <%product%>
        Installation
        
    
          		
    
    
    
    
      
      
    
      

    
      
      Sie haben alle notwendigen Informationen angegeben. Die Installation der Dateien kann beginnen...
    Bitte haben Sie Geduld, je nach verfügbarer Rechenleistung kann dieser Vorgang einige Minuten dauern. Bitte unterbrechen Sie diesen Vorgang nicht! 
      
    
      
    
          		
    
    

    

    ',
    UPGRADE_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> wurde erfolgreich installiert.

<%install_message%>


    HINWEIS: Bitte lassen Sie Ihre Original-Datei (.tar.gz) nicht in Ihrem Web-Verzeichnis!


    Wenn Sie Hilfe brauchen, besuchen Sie bitte unser Supportforum.
<%message%>
    
     
    
    


    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_WARNING => '
    WARNUNG: Bitte löschen Sie die Dateien install.cgi und install.dat aus Ihrem Verzeichnis. Wenn Sie diese Dateien nicht löschen, setzen Sie sich einem hohen Sicherheitsrisiko aus!',
    INSTALL_REMOVED => '
    Die Installationsdateien wurden gelöscht. Wenn Sie die Installation erneut durchfhren wollen, dekomprimieren Sie bitte erneut die Original-Datei.',

    OVERWRITE => 'Überschreiben',
    BACKUP => 'Backup',
    SKIP => 'Überspringen',
    INSTALL_FIRST_SCREEN => '

    
    Willkommen zu <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
        
     <%product%>
        Installation
        
    
          		
    
    
    
    
      
      
    
      

    
      Willkommen zu <%product%>. Dieses Programm wird das Archiv von <%product%> auspacken, alle notwendigen Dateien anlegen, entsprechende Rechte setzen
      und das Verzeichnis von Perl eintragen. Um mit dem Installation zu beginnen, geben Sie die folgenden Informationen an. Einige Standardwerte wurden bereits eingesetzt,
      bitte prüfen Sie diese Werte sorgfältig.      

      <%error%>
      
    

  
    <%form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_SECOND_SCREEN_FIRST => '

    
    Willkommen zu <%product%>
    
    

    
    
    
    
        
     <%product%>
        Installation
        
    
          		
    
    
    
    
      
      
    
      

    
      
      Sie haben alle notwendigen Informationen angegeben. Die Installation der Dateien kann beginnen...
    Bitte haben Sie Geduld, je nach verfügbarer Rechenleistung kann dieser Vorgang einige Minuten dauern. Bitte unterbrechen Sie diesen Vorgang nicht! 
      
    
      
    
          		
    
    

    

    ',
    INSTALL_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> wurde erfolgreich installiert.

<%install_message%>


    HINWEIS: Bitte lassen Sie Ihre Original-Datei (.tar.gz) nicht in Ihrem Web-Verzeichnis!


    Wenn Sie Hilfe brauchen, besuchen Sie bitte unser Supportforum.
<%message%>

     

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    CGI_ERROR_SCREEN => '

    
    Fehler
    
    
    
    
    
    
        
     Fehler
        
    
          		
    
    
    
    
      
      
    
      

    
      Bei der Installation trat folgender Fehler auf:

      <%error%>
      
    
      
    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INVALID_RESPONCE => "\nFalsche Antwort (%s)\n",
);

private/lib/GT/Installer/language.en0100644000076400010020000003376407461411607016200 0ustar  alexcvs
%GT::Installer::LANG = (
    ERR_REQUIRED   => "%s can not be left blank.",
    ERR_PATH       => "The path (%s) does not exist on this system",
    ERR_PATHWRITE  => "Unable to write to directory (%s). Reason: (%s)",
    ERR_PATHCREATE => "Unable to create directory (%s). Reason: (%s)",
    ERR_URLFMT     => "(%s) does not look like a URL",
    ERR_FTPFMT     => "(%s) does not look like and FTP URL",
    ERR_EMAILFMT   => "(%s) does not look like an email",
    ERR_SENDMAIL   => "The path (%s) does not exist on your system or is not executable",
    ERR_SMTP       => "(%s) is not a valid smtp server address",
    ERR_PERL      => "The path to perl you specified (%s) %s",
    ERR_DIREXISTS => "%s is not a directory but exists, unable to make a directory of that name",
    ERR_WRITEOPEN      => "Could not open %s for writting; Reason: %s",
    ERR_READOPEN      => "Could not open %s for reading; Reason: %s",
    ERR_RENAME => "Could not rename %s to %s; Reason: %s",
    ENTER_REG => 'Please enter your registration number',
    REG_NUM => 'Registration Number',
    ENTER_SENDMAIL => 'Please enter either a path to sendmail, or a SMTP server to use for sending mail',
    MAILER => 'Mailer',
    ENTER_PERL => 'Please enter the path to perl 5',
    PATH_PERL => 'Path to Perl',
    CREATE_DIRS => 'Create Directories',
    INSTALL_CURRUPTED => '
install.dat appears to be corrupted. Please make sure you transfer 
the file in BINARY mode when using FTP. Otherwise you may have a 
corrupted file, and you should try downloading a new file from 
Gossamer Threads.

If you need assistance, please visit: 
    http://gossamer-threads.com/scripts/support/
',
   INSTALL_VERSION => '
This program requires perl version 5.004_04 or greater to run. Your
system is only running version %s. Try changing the path to perl in
install.cgi to a newer version, or contact your ISP for help.
',
   ADMIN_PATH_ERROR => "You must specify the path to the previous install's admin area",
   INTRO => '
%s Quick Install http://gossamer-threads.com
Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved
Redistribution in part or in whole strictly prohibited.

Please see LICENSE file for full details.
',
    WELCOME => '
Welcome to the %s auto install. This program will
unarchive the %s program, and create all the 
files neccessary, and set all permissions properly.

To begin, please enter the following information. Type exit or
quit at any time to abort.
',
    IS_UPGRADE => "Is this an upgrade of an existing installation",
    ENTER_ADMIN_PATH => "\nPlease enter path to current admin",
    UNARCHIVING => 'Unarchiving',
    TAR_OPEN        => "Could not open %s. Reason: %s",
    TAR_READ        => "There was an error reading from %s. Expected to read %s bytes, but only got %s.",
    TAR_BINMODE     => "Could not binmode %s. Reason: %s",
    TAR_BADARGS     => "Bad arguments passed to %s. Reason: %s",
    TAR_CHECKSUM    => "Checksum Error parsing tar file. Most likely this is a corrupt tar.\nHeader: %s\nChecksum: %s\nFile: %s\n",
    TAR_NOBODY      => "File '%s' does not have a body!",
    TAR_CANTFIND    => "Unable to find a file named: '%s' in tar archive.",
    TAR_CHMOD       => "Could not chmod %s, Reason: %s",
    TAR_DIRFILE     => "'%s' exists and is a file. Cannot create directory",
    TAR_MKDIR       => "Could not mkdir %s, Reason: %s",
    TAR_RENAME      => "Unable to rename temp file: '%s' to tar file '%s'. Reason: %s",
    TAR_NOGZIP      => "Compress::Zlib module is required to work with .tar.gz files.",
    SKIPPING_FILE => "Skipping %s\n",
    OVERWRITTING_FILE => "Overwritting %s\n",
    SKIPPING_MATCHED => "Skipping %s in matched directory\n",
    BACKING_UP_FILE => "Backing up %s\n",
    ERR_OPENTAR => '
Unable to open the install.dat file! Please make sure the
file exists, and the permissions are set properly so the
program can read the file.

The error message was: 
    %s

If you need assistance, please visit: 
    http://gossamer-threads.com/scripts/support/
',
    ERR_OPENTAR_UNKNOWN => '
Unknown error opening tar file:
    %s

If you need assistance, please visit:
http://gossamer-threads.com/scripts/support/
',
    WE_HAVE_IT => "\nWe have everything we need to proceed.\n\n",
    ENTER_STARTS => "\nPress ENTER to install, or CTRL-C to abort",
    NOW_UNARCHIVING => '

We are now unarchiving %s and will be extracting
all the files shortly. Please be patient ...
',
    UPGRADE_DONE => '

Congratulations! Your copy of %s has now been 
updated to version %s. The install files have 
been removed.

If you need to re-run the install, please unarchive the 
original file again.
',
    INSTALL_DONE => '

%s is now unarchived. The install files have been 
removed. If you need to re-run the install, please unarchive 
the original file again.

NOTE: Please do not leave your original .tar.gz file in your
web directory!

',
    TELNET_ERR => 'Error: %s',
    FIRST_SCREEN => '

    
    Welcome to <%product%> <%version%>
    
    
    
    
    
    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      Welcome to <%product%>. This program will unarchive <%product%>, and set all the file permissions
      and path to perl properly. 
        
      <%error%>

      
     

  
    <%message%>
    
    
      
        Please select if this is a new install or an upgrade to an exiting version.
    
    
    
    
      New Install
      
    
    
    
    
      Upgrade Existing Installation
      
    
    
    
    
      Path to Existing Installation admin area:
    
    
    
    
      
    
    
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_FIRST_SCREEN => '

    
    Welcome to <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      Welcome to <%product%>. This program will unarchive <%product%>, and set all the file permissions
      and path to perl properly. You need to know the following information before continuing. Sensible defaults have been chosen, but please double check
      that they are correct.

      <%error%>
      
     

  
    <%upgrade_form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_SECOND_SCREEN_FIRST => '

    
    Welcome to <%product%>
    
    

    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      
      We are now going to unarchive the script, please be patient and do not hit stop.
      
    
      
    
          		
    
    

    

    ',
    UPGRADE_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> is now unarchived.

<%install_message%>


    Please do not leave your original .tar.gz file in your web directory!


    If you have any problems, please visit our support forum.
<%message%>
    
     
    
    


    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_WARNING => '
    WARNING: Please remove the install.cgi and install.dat file from this directory. It is a security risk to leave those files here.',
    INSTALL_REMOVED => '
    The install files have been removed. If you need to re-run the install, please unarchive the
                    original file again.',

    OVERWRITE => 'Overwrite',
    BACKUP => 'Backup',
    SKIP => 'Skip',
    INSTALL_FIRST_SCREEN => '

    
    Welcome to <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      Welcome to <%product%>. This program will unarchive <%product%>, and set all the file permissions
      and path to perl properly. You need to know the following information before continuing. Sensible defaults have been chosen, but please double check
      that they are correct.

      <%error%>
      
    

  
    <%form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_SECOND_SCREEN_FIRST => '

    
    Welcome to <%product%>
    
    

    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      
      We are now going to unarchive the script, please be patient and do not hit stop.
      
    
      
    
          		
    
    

    

    ',
    INSTALL_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> is now unarchived.

<%install_message%>


    Please do not leave your original .tar.gz file in your web directory!


    If you have any problems, please visit our support forum.
<%message%>

     

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    CGI_ERROR_SCREEN => '

    
    Error
    
    
    
    
    
    
        
     Error
        
    
          		
    
    
    
    
      
      
    
      

    
      An error occured:

      <%error%>
      
    
      
    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INVALID_RESPONCE => "\nInvalid Responce (%s)\n",
);

private/lib/GT/Installer/language.fr0100644000076400010020000003566507461411607016207 0ustar  alexcvs
%GT::Installer::LANG = (
    ERR_REQUIRED   => "%s ne peut pas tre vide.",
    ERR_PATH       => "Le chemin (%s) n'existe pas sur ce systme.",
    ERR_PATHWRITE  => "Impossible d'crire dans le rpertoire (%s). Raison : (%s)",
    ERR_PATHCREATE => "Impossible de crer le rpertoire (%s). Raison : (%s)",
    ERR_URLFMT     => "(%s) ne semble pas tre une URL",
    ERR_FTPFMT     => "(%s) ne semble pas tre une URL FTP",
    ERR_EMAILFMT   => "(%s) ne semble pas tre un email",
    ERR_SENDMAIL   => "Le chemin (%s) n'existe pas sur votre systme ou n'est pas excutable",
    ERR_SMTP       => "(%s) n'est pas une adresse de serveur smtp valide",
    ERR_PERL      => "Le chemin de Perl spcifi (%s) %s",
    ERR_DIREXISTS => "%s n'est pas un rpertoire mais existe, impossible de crer un rpertoire de ce nom",
    ERR_WRITEOPEN      => "Impossible d'ouvrir %s pour y crire. Raison : %s",
    ERR_READOPEN      => "Impossible d'ouvrir %s pour le lire. Raison : %s",
    ERR_RENAME => "Impossible de renommer %s par %s; Raison : %s",
    ENTER_REG => 'Merci d\'entrer votre numro d\'enregistrement',
    REG_NUM => 'Numro d\'enregistrement',
    ENTER_SENDMAIL => 'Entrez soit le chemin de sendmail, soit un serveur SMTP  utiliser pour envoyer des emails',
    MAILER => 'Mailer',
    ENTER_PERL => 'Entrez le chemin de Perl 5',
    PATH_PERL => 'Chemin de Perl',
    CREATE_DIRS => 'Cration des Rpertoires',
    INSTALL_CURRUPTED => '
install.dat semble corrompu. Soyez sr d\'avoir transfr le fichier en mode BINAIRE avec votre FTP. Ou alors vous avez peut-tre un fichier corrompu, dans ce cas vous devriez essayer de tlcharger un nouveau fichier  partir de Gossamer Threads.

Si vous avez besoin d\'aide visitez : 
    http://gossamer-threads.com/scripts/support/
',
   INSTALL_VERSION => '
Ce programme requiert Perl version 5.004_04 ou plus pour fonctionner. Votre systme utilise seulement la version %s. Essayez de changer le chemin de perl dans install.cgi pour une version suprieure, ou contactez votre hbergeur pour de l\'aide.
',
   ADMIN_PATH_ERROR => "Vous devez spcifier le chemin d'installation prcdent de la zone d'Administration",
   INTRO => '
%s Installation Rapide http://gossamer-threads.com
Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved
Redistribution in part or in whole strictly prohibited.

Lisez le fichier LICENSE pour plus de dtails.
',
    WELCOME => '
Bienvenue dans l\'auto-installation de %s. Ce programme va dcompresser le programme %s, crer tous les fichiers ncessaires, et paramtrer toutes les permissions proprement.

Pour commencer, entrez les informations suivantes. Vous pouvez sortir  tout moment pour abandonner.
',
    IS_UPGRADE => "Est-ce une mise  jour d'une installation existante",
    ENTER_ADMIN_PATH => "\nEntrez le chemin vers l'administration actuelle",
    UNARCHIVING => 'Dcompactage',
    TAR_OPEN        => "Impossible d'ouvrir %s. Raison: %s",
    TAR_READ        => "Il s'est produit une erreur en lisant %s. Nous aurions d lire %s octets, mais en avons seulement eu %s.",
    TAR_BINMODE     => "Impossible de binmode %s. Raison: %s",
    TAR_BADARGS     => "Mauvais arguments transmis  %s. Raison: %s",
    TAR_CHECKSUM    => "Erreur de Checksum en plaant le fichier tar. Il s'agit trs probablement d'un tar corrompu.\nHeader: %s\nChecksum: %s\nFichier: %s\n",
    TAR_NOBODY      => "Le fichier '%s' n'a pas de corps!",
    TAR_CANTFIND    => "Impossible de trouver un fichier dans l'archive, nomm: '%s'.",
    TAR_CHMOD       => "Impossible de chmoder %s, Raison: %s",
    TAR_DIRFILE     => "'%s' existe et est un fichier. Impossible de crer le rpertoire",
    TAR_MKDIR       => "Impossible de crer %s, Raison: %s",
    TAR_RENAME      => "Impossible de renommer le fichier temp: '%s' par le fichier tar '%s'. Raison: %s",
    TAR_NOGZIP      => "Compression::Module Zlib requis pour faire fonctionner des fichiers .tar.gz.",
    SKIPPING_FILE => "Ignorer %s\n",
    OVERWRITTING_FILE => "Remplacer %s\n",
    SKIPPING_MATCHED => "Ignorer %s dans le rpertoire trouv\n",
    BACKING_UP_FILE => "Sauvegarde de %s\n",
    ERR_OPENTAR => '
Impossible d\'ouvrir le fichier install.dat! Soyez certain que le fichier existe, et que les permissions sont paramtres correctement pour que le programme lise le fichier.

Le message d\'erreur est le suivant: 
    %s

Si vous avez besoin d\'aide visitez: 
    http://gossamer-threads.com/scripts/support/
',
    ERR_OPENTAR_UNKNOWN => '
Erreur inconnue en ouvrant le fichier tar:
    %s

Si vous avez besoin d\'aide visitez: 
http://gossamer-threads.com/scripts/support/
',
    WE_HAVE_IT => "\nNous avons tout ce qui est ncessaire pour procder.\n\n",
    ENTER_STARTS => "\nAppuyez sur ENTRE pour installer, ou CTRL-C pour abandonner",
    NOW_UNARCHIVING => '

Nous dcompactons actuellement %s et nous dcompresserons tous les fichiers rapidement. Patientez s\'il vous plat...
',
    UPGRADE_DONE => '

Flicitations! Votre copie de %s a t mise  jour vers la version %s. Les fichiers d\'installation ont t supprims.

Si vous devez relancer l\'installation, dcompactez le fichier original une nouvelle fois.
',
    INSTALL_DONE => '

%s est maintenant dcompact. Les fichiers d\'installation ont t supprims. Si vous devez relancer l\'installation, dcompactez le fichier original une nouvelle fois.

NOTE: Ne laissez pas votre fichier original .tar.gz dans votre rpertoire web!

',
    TELNET_ERR => 'Erreur: %s',
    FIRST_SCREEN => '

    
    Bienvenue dans <%product%> <%version%>
    
    
    
    
    
    
    
    
    
        
     Installation de <%product%>
        
        
    
          		
    
    
    
    
      
      
    
      

    
      Bienvenue dans <%product%>. Ce programme va dcompacter <%product%>, et paramtrer toutes les permissions de fichier
      ainsi que le chemin de perl correctement. 
        
      <%error%>

      
     

  
    <%message%>
    
    
      
        Merci de choisir si vous souhaitez raliser une nouvelle installation ou bien effectuer une mise  jour.
    
    
    
    
      Nouvelle Installation
      
    
    
    
    
      Mettre  Jour une Installation xistante
      
    
    
    
    
      Chemin de la zone d\'administration existante:
    
    
    
    
      
    
    
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_FIRST_SCREEN => '

    
    Bienvenue dans <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
    
        
     Installation de <%product%>
        
        
    
          		
    
    
    
    
      
      
    
      

    
      Bienvenue dans <%product%>. Ce programme va dcompacter <%product%>, et paramtrer toutes les permissions de fichier
      ainsi que le chemin de perl correctement. Vous devez connatre les informations suivantes avant de continuer. Des paramtres par dfaut ont t choisis, mais vrifiez
      qu\'ils sont bien corrects.

      <%error%>
      
     

  
    <%upgrade_form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_SECOND_SCREEN_FIRST => '

    
    Bienvenue dans <%product%>
    
    

    
    
    
    
        
     Installation de <%product%>
        
        
    
          		
    
    
    
    
      
      
    
      

    
      
      Nous allons maintenant dcompacter le script, veuillez patienter s\'il vous plat, et ne pas cliquer sur Arrter.
      
    
      
    
          		
    
    

    

    ',
    UPGRADE_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> est maintenant dcompact.

<%install_message%>


    Merci de ne pas laisser votre fichier .tar.gz original dans votre rpertoire web!


    Si vous avez un problme, visitez notre forum d\'assistance.
<%message%>
    
     
    
    


    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_WARNING => '
    ATTENTION: Supprimez les fichiers install.cgi et install.dat de ce rpertoire. Il y a un risque de scurit en les laissant ici.',
    INSTALL_REMOVED => '
    Les fichiers d\'installation ont t supprims. Si vous devez relancer l\'installation, dcompactez une nouvelle fois le fichier original.',

    OVERWRITE => 'Remplacer',
    BACKUP => 'Sauvegarder',
    SKIP => 'Ignorer',
    INSTALL_FIRST_SCREEN => '

    
    Bienvenue dans <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
        
     Installation de <%product%>
        
        
    
          		
    
    
    
    
      
      
    
      

    
      Bienvenue dans <%product%>. Ce programme va dcompacter <%product%>, et paramtrer toutes les permissions de fichier
      ainsi que le chemin de perl correctement. Vous devez connatre les informations suivantes avant de continuer. Des paramtres par dfaut ont t choisis, mais vrifiez
      qu\'ils sont bien corrects.

      <%error%>
      
    

  
    <%form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_SECOND_SCREEN_FIRST => '

    
    Bienvenue dans <%product%>
    
    

    
    
    
    
        
     Installation de <%product%>
        
        
    
          		
    
    
    
    
      
      
    
      

    
      
      Nous allons maintenant dcompacter le script, veuillez patienter s\'il vous plat, et ne pas cliquer sur Arrter.
      
    
      
    
          		
    
    

    

    ',
    INSTALL_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> est maintenant dcompact.

<%install_message%>


    Merci de ne pas laisser votre fichier .tar.gz original dans votre rpertoire web!


    Si vous avez des problmes, visitez notre forum d\'assistance.
<%message%>

     

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    CGI_ERROR_SCREEN => '

    
    Erreur
    
    
    
    
    
    
        
     Erreur
        
    
          		
    
    
    
    
      
      
    
      

    
      Une erreur s\'est produite:

      <%error%>
      
    
      
    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INVALID_RESPONCE => "\nRponse Invalide (%s)\n",
);

private/lib/GT/Installer/language.sp0100644000076400010020000003522007461411607016205 0ustar  alexcvs
%GT::Installer::LANG = (
    ERR_REQUIRED   => "%s no se puede dejar en blanco.",
    ERR_PATH       => "El path (%s) no existe en el sistema",
    ERR_PATHWRITE  => "Incapaz de escribir en el directorio (%s). Razon: (%s)",
    ERR_PATHCREATE => "Incapaz de crear directorio (%s). Razon: (%s)",
    ERR_URLFMT     => "(%s) parece no ser un URL",
    ERR_FTPFMT     => "(%s) parece no ser un URL de FTP",
    ERR_EMAILFMT   => "(%s) parece no ser un email",
    ERR_SENDMAIL   => "El path (%s) no existe en su sistema o no es ejecutable",
    ERR_SMTP       => "(%s) no es una direccion de servidor smptp valida",
    ERR_PERL      => "El path a perl usted especifico (%s) %s",
    ERR_DIREXISTS => "%s no es un directorio pero existe, no se puede hacer un directorio de ese nombre",
    ERR_WRITEOPEN      => "No se pudo abrir %s por escritura; Razon: %s",
    ERR_READOPEN      => "No se pudo abrir %s por lectura; Razon: %s",
    ERR_RENAME => "No se pudo renombrar %s to %s; Razon: %s",
    ENTER_REG => 'Por favor ingrese su numero de registro',
    REG_NUM => 'Numero de Registro',
    ENTER_SENDMAIL => 'Por favor ingrese ya sea el path a sendmail, o el servidor  SMTP a usar para enviar Correo',
    MAILER => 'Mailer',
    ENTER_PERL => 'Por favor ingrese el path a perl 5',
    PATH_PERL => 'Path a Perl',
    CREATE_DIRS => 'Crear Directorios',
    INSTALL_CURRUPTED => '
install.dat parece estar corrupto. favor de asegurarse que transfiere el archivo en modo BINARIO 
cuando use FTP. de otro modo usted podra obtener el archivo corrupto, y tendra que volver a bajar un nuevo archivo desde 
Gossamer Threads.

Si necesita asistencia, favor de visitar: 
    http://gossamer-threads.com/scripts/support/
',
   INSTALL_VERSION => '
Este programa requiere la version perl 5.004_04 o mas nueva para correr. Su
Sistema esta corriendo la version %s. Trate cambiando el path a perl en
install.cgi a la version mas actual, o contacte a su ISP para ayuda.
',
   ADMIN_PATH_ERROR => "Usted tiene que especificar el path al area de administracion de la instalacion previa",
   INTRO => '
%s Quick Install http://gossamer-threads.com
Copyright (c) 2001 Gossamer Threads Inc. Todos los derechos Reservados
Redistribucion en parte o total es extrictamente prohibida.

Por favor vea el archivo de LICENCIA para detalles mas completos.
',
    WELCOME => '
Bienvenido al %s auto install. Este programa
descompactara el %s programa, y creara todos los  
archivos necesarios, y pondra todos los permisos de manera propia.

Para empezar, por favor ingrese la siguiente informacion. presione exit o
quit en cualquier momento para abortar.
',
    IS_UPGRADE => "Es esta una actualizacion de una instalacion ya existente",
    ENTER_ADMIN_PATH => "\npor favor ingrese el path al actual admin",
    UNARCHIVING => 'Descomprimiendo',
    TAR_OPEN        => "No se pudo abrir %s. Razon: %s",
    TAR_READ        => "Hubo un error leyendo desde %s. Se suponia leyera %s bytes, pero solo leyo %s.",
    TAR_BINMODE     => "No se pudo modo binario %s. Razon: %s",
    TAR_BADARGS     => "Malos argumentos se pasaron a %s. Razon: %s",
    TAR_CHECKSUM    => "analisis de chequeo de archivo tar. Es muy probable este corrupto el tar.\nHeader: %s\nChecksum: %s\nFile: %s\n",
    TAR_NOBODY      => "Archivo '%s' no tiene contenido!",
    TAR_CANTFIND    => "Incapaz de encontrar un archivo llamado: '%s' en archivo tar.",
    TAR_CHMOD       => "No se pudo chmod %s, Razon: %s",
    TAR_DIRFILE     => "'%s' existe y es un archivo. No se puede crear directorio",
    TAR_MKDIR       => "No se pudo mkdir %s, Razon: %s",
    TAR_RENAME      => "No se puede renombrar el archivo temporal: '%s' to tar file '%s'. Razon: %s",
    TAR_NOGZIP      => "Comprimir::El modulo Zlib es requerido para trabajar con archivos .tar.gz .",
    SKIPPING_FILE => "Saltandose %s\n",
    OVERWRITTING_FILE => "Sobreescribiendo %s\n",
    SKIPPING_MATCHED => "Saltandose %s en directorio concordante\n",
    BACKING_UP_FILE => "Respaldando %s\n",
    ERR_OPENTAR => '
No se puede abrir el archivo install.dat! por favor asegurese de que
el archivo existe, y los permisos estan puestos apropiadamente y asi el programa
podra leer el archivo.

El mensaje de error fue: 
    %s

Si necesita asistencia, favor de visitar: 
    http://gossamer-threads.com/scripts/support/
',
    ERR_OPENTAR_UNKNOWN => '
error desconocido al abrir el archivo tar:
    %s

Si necesita asistencia, favor de visitar: 
http://gossamer-threads.com/scripts/support/
',
    WE_HAVE_IT => "\nTenemos todo lo que necesitamos para proceder.\n\n",
    ENTER_STARTS => "\nPresione ENTER para instalar, o CTRL-C para  abortar",
    NOW_UNARCHIVING => '

Ahora estamos descomprimiendo %s y terminara de extraer todos los archivos
dentro de poco. Sea paciente ...
',
    UPGRADE_DONE => '

Felicidades! Su copia de %s ha sido ya 
actualizada a la version %s. Los archivos de instalacion han sido eliminados.

Si necesita volver a correr el instalador, favor de descomprimir el archivo 
original de nuevo.
',
    INSTALL_DONE => '

%s esta ya desomprimido. Los archivos de instalacion han sido eliminados. 
Si necesita volver a correr el instalador, favor de descomprimir el archivo 
original de nuevo.

NOTA: Por favor no deje el archivo original .tar.gz file en su
directorio web!

',
    TELNET_ERR => 'Error: %s',
    FIRST_SCREEN => '

    
    Bienvenido a <%product%> <%version%>
    
    
    
    
    
    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      Bienvenido a <%product%>. Este programa descomprimira <%product%>, y pondra todos los permisos de archivo y el path a perl de manera propia. 
        
      <%error%>

      
     

  
    <%message%>
    
    
      
        Por favor seleccione si esta es una nueva instalacion o una actualizacion de una version existente.
    
    
    
    
      Nueva Instalacion
      
    
    
    
    
      Actualizar Instalacion Existente
      
    
    
    
    
      Path a el area de admin de la Instalacion Existente:
    
    
    
    
      
    
    
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_FIRST_SCREEN => '

    
    Bienvenido a <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      Bienvenido a <%product%>. Este programa descomprimira <%product%>, y pondra todos los permisos de archivo
      y path a perl de manera propia. Usted necesita saber la siguiente informacion antes de continuar. Los defaults sensibles han sido escogidos, pero por favor cheque de
      nuevo que son correctos.

      <%error%>
      
     

  
    <%upgrade_form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    UPGRADE_SECOND_SCREEN_FIRST => '

    
    Welcome to <%product%>
    
    

    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      
      Ahora descomprimiremos el script, por favor sea paciente y no cancele ni presione stop.
      
    
      
    
          		
    
    

    

    ',
    UPGRADE_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> esta ahora descomprimido.

<%install_message%>


    Por favor no deje su archivo original .tar.gz en su directorio web!


    Si usted tiene algun problema, por favor visite nuestro sitio de soporter .
<%message%>
    
     
    
    


    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_WARNING => '
    PRECAUCION: Por favor remueva los archivos install.cgi e install.dat de este directorio. Habra un riesgo de seguridad si los deja aqui.',
    INSTALL_REMOVED => '
    Los archivos de instalacion han sido eliminados. Si usted necesita  volver a correr el instalador, por favor descomprima
                    el archivo original de nuevo.',

    OVERWRITE => 'Sobreescribir',
    BACKUP => 'Respaldar',
    SKIP => 'Saltar',
    INSTALL_FIRST_SCREEN => '

    
    Bienvenido a <%product%> <%version%>
    
    
    
    
    
    
    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      Bienvenido a <%product%>. Este programa descomprimira <%product%>, y pondra todos los permisos de archivo
      y path a perl de manera propia. Usted necesita saber la siguiente informacion antes de continuar. Los defaults sensibles han sido seleccionados, pero por favor
      cheque de nuevo que son correctos.

      <%error%>
      
    

  
    <%form%>
  
    

      
    

     

    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INSTALL_SECOND_SCREEN_FIRST => '

    
    Bienvenido a <%product%>
    
    

    
    
    
    
        
     <%product%>
        Install
        
    
          		
    
    
    
    
      
      
    
      

    
      
      Ahora descomprimiremos el script, por favor sea paciente y no cancele o presione stop.
      
    
      
    
          		
    
    

    

    ',
    INSTALL_SECOND_SCREEN_SECOND => '

    

    


    

    


    <%product%> esta ahora descomprimido.

<%install_message%>


    Por favor no deje el archivo original .tar.gz en su directorio web!


    Si usted tiene algun problema, por favor visite nuestro sitio de soporte .
<%message%>

     

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    CGI_ERROR_SCREEN => '

    
    Error
    
    
    
    
    
    
        
     Error
        
    
          		
    
    
    
    
      
      
    
      

    
      Un error ha ocurrido:

      <%error%>
      
    
      
    

    

    Copyright 2001 Gossamer
Threads Inc. 
    


',
    INVALID_RESPONCE => "\nRespuesta Invalida (%s)\n",
);

private/lib/bases.pm0100644000076400010020000000552707454355267013264 0ustar  alexcvs# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   bases
#   Author: Scott Beck
#   $Id: bases.pm,v 1.8 2002/04/08 18:00:23 jagerman Exp $
#
# Copyright (c) 2001 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================

package bases;

use strict 'subs', 'vars';

sub import {
    my $class = shift;
    my $pkg = caller;
    my $hsh = {@_};
    my @indices = map { $_[$_ * 2] } 0 .. $#_ * 0.5;
    foreach my $base (@indices) {
        next if $pkg->isa($base);
        push @{"$pkg\::ISA"}, $base;
        my $args = '';
        if (my $ref = ref $hsh->{$base}) {
            require GT::Dumper;
            if ($ref eq 'ARRAY') {
                $args = '(@{' . GT::Dumper->dump_structure($hsh->{$base}) . '})';
            }
            else {
                $args = '(' . GT::Dumper->dump_structure($hsh->{$base}) . ')';
            }
        }
        elsif (defined $hsh->{$base}) {
            $args = $hsh->{$base} eq '' ? '()' : "qw($hsh->{$base})";
        }
        my $dcl = qq|
            package $pkg;
            use $base $args;
        |;
        eval $dcl;
        die "$@: $dcl" if $@ && $@ !~ /^Can't locate .*? at \(eval /;
        unless (defined %{"$base\::"}) {
            require Carp;
            Carp::croak(
qq|Base class package "$base" is empty.
String:
$dcl
\t(Perhaps you need to 'use' the module which defines that package first.)|
            );
        }
    }
}

1;

__END__

=head1 NAME

base - Establish IS-A relationship with base class at compile time.

=head1 SYNOPSIS

    package Baz;
    use bases
        Foo  => ':all',
        Bar  => ''
        Bat  => undef;

=head1 DESCRIPTION

Roughly similar in effect to

    package Baz;
    use Foo qw(:all);
    use Bar();
    use Bat;
    BEGIN { @ISA = qw(Foo Bar Bat) }

This is very similar to C pragma except %FIELDS is not
supported and you are able to pass parameters to import on the
module that is used in this way.

If the value specified is undef, the module being used import method
will be called if it exists. If the value is an empty string, import
will not be called.

When strict 'vars' is in scope I also let you assign to @ISA
without having to declare @ISA with the 'vars' pragma first.

If any of the base classes are not loaded yet, I silently
Cs them.  Whether to C a base class package is
determined by the absence of a global $VERSION in the base package.
If $VERSION is not detected even after loading it,  will
define $VERSION in the base package, setting it to the string
C<-1, set by bases.pm>.

=head1 COPYRIGHT

Copyright (c) 2000 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: bases.pm,v 1.8 2002/04/08 18:00:23 jagerman Exp $

=cut

private/lib/constants.pm0100644000076400010020000001107307453737207014171 0ustar  alexcvs# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   constants
#   Author: Jason Rhinelander
#   $Id: constants.pm,v 1.8 2002/04/07 03:35:35 jagerman Exp $
#
# Copyright (c) 2001 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description:
#   Lightweight version of the standard constant.pm that allows you
#   to declare multiple scalar constants in a single compile-time
#   command. Like constant.pm, these scalar constants are optimized
#   during Perl's compilation stage.
#   Unlike constant.pm, this does not allow you to declare list
#   constants.

package constants;


use strict;
use Carp;
use vars qw($VERSION);

$VERSION = '1.00';

#=======================================================================

# Some of this stuff didn't work in version 5.003, alas.
require 5.003_96;

#=======================================================================
# import() - import symbols into user's namespace
#
# What we actually do is define a function in the caller's namespace
# which returns the value. The function we create will normally
# be inlined as a constant, thereby avoiding further sub calling 
# overhead.
#=======================================================================
sub import {
    my $class = shift;
    @_ or return; # Ignore 'use constant;'
    my %constants = @_;
    my $pkg = caller;
    {
        no strict 'refs';
        for my $name (keys %constants) {
            croak qq{Can't define "$name" as constant} .
                qq{ (name contains invalid characters or is empty)}
                unless $name =~ /^[^\W_0-9]\w*$/;
            my $scalar = $constants{$name};
            *{"${pkg}::$name"} = sub () { $scalar };
        }
    }

}

1;

__END__

=head1 NAME

constants - Perl pragma to declare multiple scalar constants at once

=head1 SYNOPSIS

    use constants BUFFER_SIZE   => 4096,
                  ONE_YEAR      => 365.2425 * 24 * 60 * 60,
                  PI            => 4 * atan2 1, 1,
                  DEBUGGING     => 0,
                  ORACLE        => 'oracle@cs.indiana.edu',
                  USERNAME      => scalar getpwuid($<);

    sub deg2rad { PI * $_[0] / 180 }

    print "This line does nothing" unless DEBUGGING;

    # references can be declared constants
    use constants CHASH         => { foo => 42 },
                  CARRAY        => [ 1,2,3,4 ],
                  CPSEUDOHASH   => [ { foo => 1}, 42 ],
                  CCODE         => sub { "bite $_[0]\n" };

    print CHASH->{foo};
    print CARRAY->[$i];
    print CPSEUDOHASH->{foo};
    print CCODE->("me");
    print CHASH->[10];                          # compile-time error

=head1 DESCRIPTION

This will declare a symbol to be a constant with the given scalar
value. This module mimics constant.pm in every way, except that it
allows multiple scalar constants to be created simultaneously. To
create constant list values you should use constant.

See L for details about how constants work.

=head1 NOTES

The value or values are evaluated in a list context, so you should
override this if needed with C as shown above.

=head1 TECHNICAL NOTE

In the current implementation, scalar constants are actually
inlinable subroutines. As of version 5.004 of Perl, the appropriate
scalar constant is inserted directly in place of some subroutine
calls, thereby saving the overhead of a subroutine call. See
L for details about how and when this
happens.

=head1 BUGS

In the current version of Perl, list constants are not inlined
and some symbols may be redefined without generating a warning.

It is not possible to have a subroutine or keyword with the same
name as a constant. This is probably a Good Thing.

Unlike constants in some languages, these cannot be overridden
on the command line or via environment variables.

You can get into trouble if you use constants in a context which
automatically quotes barewords (as is true for any subroutine call).
For example, you can't say C<$hash{CONSTANT}> because C will
be interpreted as a string.  Use C<$hash{CONSTANT()}> or
C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from
kicking in.  Similarly, since the C<=E> operator quotes a bareword
immediately to its left you have to say C 'value'>
instead of C 'value'>.

=head1 AUTHOR

constant.pm: Tom Phoenix, EFE, with help from
many other folks.

constants.pm: Jason Rhinelander, Gossamer Threads Inc.

=cut
private/tmp/0040777000076400010020000000000007477023140011644 5ustar  alexcvsprivate/.htaccess0100644000076400010020000000012307402745226012633 0ustar  alexcvsAuthGroupFile  /dev/null
AuthName       Protected
AuthType Basic 

deny from all


private/templates/0040755000076400010020000000000007477023140013036 5ustar  alexcvsprivate/templates/common/0040755000076400010020000000000007477023140014326 5ustar  alexcvsprivate/templates/common/compiled/0040777000076400010020000000000007477023140016126 5ustar  alexcvsprivate/templates/common/editor.js0100666000076400010020000011161607467030172016163 0ustar  alexcvs/*  
 * =================================================================
 * HTML Editor - A wysiwyg web based editor for IE5.5+
 *    Website  : http://gossamer-threads.com/
 *    Revision : $Id: editor.js,v 1.12 2002/05/10 20:41:30 bao Exp $
 *
 * Copyright (c) 2002 Gossamer Threads Inc. All Rights Reserved.
 * Redistribution in part or in whole strictly prohibited. Please
 * see LICENSE file for full details.
 * =================================================================
 *
 * Description: Common functions needed to display the toolbar for an
 * HTML-editing iframe, as used in Gossamer Forum.
 */

/* -- Javascript needed to write a post -- */

var url = window.location.protocol + '//' + window.location.hostname + window.location.pathname + '?<%url_opts%>';

var image_url = '<%html_url%>/tools';

var iframe, editor, inner_content, outerdoc; // iframe is the inner iframe, editor is the editor (document object), and content is the editor's body.

var innerInterval, tbInterval, pressedInterval, initialized;

var controlRange; // selection is a ControlRange collection

window.onresize = tb_layout;

var unStack = new Array();
var reStack = new Array();
var unPress = false;

function initOuterIFrame () {
    // How fun - we write the HTML (which includes JavaScript) for this iframe, then write the HTML for the iframe contained within the iframe. :)
    document.frames.editor_iframe.document.write('<%GT::FileMan::js_quote_include('editor_iframe.html')%>');
    innerInterval = setInterval("initInnerIFrame()", 100);
}

function initInnerIFrame () {
    if ( typeof(document.frames.editor_iframe.document.editor_iframe) != 'undefined' && typeof(document.frm_main.pre_content) != 'undefined' ) {
        clearInterval(innerInterval);
    }
    else {
        return; // The inner 


private/templates/common/editor_image.html0100666000076400010020000000110107424120127017631 0ustar  alexcvs
Insert Image
  




    
	
    
		Picture Source
	
    

    

    

    
	  
	

    


private/templates/common/editor_radio.html0100666000076400010020000000304307426631645017672 0ustar  alexcvs
Radio





    
	
    
		Group Name:
	
    
	
    
		Value:
	
    
	
    
		Initial State:
		
			
    
				
    
					
						 Selected
					
					
						 Not Selected
					
				
    
			
    
		    		
	
    
	
    
		Tab order:
	
    

    

    

    
	  
	

    


private/templates/common/editor_select.html0100666000076400010020000002462207426631645020061 0ustar  alexcvs
Insert Select Field





    
	
    
		Name:   
	
    
	
    
		
			
    
				
    
					 Choice Selected Value
				
    
			
    
		    		
		
			
    
			
    
			
    
			
    
			
    
		    		
	
    
	
    
		
			
    
				
    
					Height: 
					
					Allow multiple selections: 
					 Yes
				
    
				
    
					Tab order: 
					
					   
					 No
				
    
			
    
		    		
		   
	
    

    

    

    
	  
	

    


private/templates/common/editor_select_option.html0100666000076400010020000000324207426631645021444 0ustar  alexcvs
Add Option





    
	
    
		Option: 
	
    
		
    Value: 
	
    
	
    
		Selected: Yes No
	
    

    

    

    
	  
	

    

private/templates/common/editor_style.css0100666000076400010020000000722507424124322017551 0ustar  alexcvs/* 
 * =================================================================
 * HTML Editor - A wysiwyg web based editor for IE5.5+
 *    Website  : http://gossamer-threads.com/
 *    Author   : Scott Beck sbeck@gossamer-threads.com
 *    Revision : $Id: editor_style.css,v 1.1 2002/01/25 00:37:38 bao Exp $
 *
 * Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
 * Redistribution in part or in whole strictly prohibited. Please
 * see About file for full details.
 * =================================================================
 *
 * Description: Style sheet for the main editor window.
 */

body {
        scrollbar-base-color: #404040;
        scrollbar-arrow-color: #00ff33;
}

.tb_icon {
	position : absolute;
	width    : 22px;
	height   : 22px;
	left     : -1px;
	top      : -1px;
}

.icon_down {
	position : absolute;
	left     : 0px;
	top      : 0px;
	height   : 23px; 
	width    : 24px;
}

.icon_downpressed {
	position : absolute;
	left     : 1px;
	top      : 1px;
}

.tb_menu_item {
	position      : absolute;
	border-bottom : <%editor_base_color%> solid 1px; 
	border-left   : <%editor_base_color%> solid 1px; 
	border-right  : <%editor_base_color%> solid 1px; 
	border-top    : <%editor_base_color%> solid 1px; 
	top           : 1px;
	height        : 22px;
	width         : 23px;
}

.menu_item_mouseoverup {
	position      : absolute;
	border-bottom : buttonshadow solid 1px; 
	border-left   : buttonhighlight solid 1px; 
	border-right  : buttonshadow solid 1px; 
	border-top    : buttonhighlight solid 1px; 
	top           : 1px;
	height        : 22px; 
	width         : 23px;
}

.menu_item_mouseoverdown {
	position      : absolute;
	border-bottom : buttonhighlight solid 1px; 
	border-left   : buttonshadow solid 1px; 
	border-right  : buttonhighlight solid 1px; 
	border-top    : buttonshadow solid 1px; 
	top           : 1px;
	height        : 22px; 
	width         : 23px;
}

.menu_item_down {
	position         : absolute;
	background-color : gainsboro; 
	border-bottom    : buttonhighlight solid 1px; 
	border-left      : buttonshadow solid 1px; 
	border-right     : buttonhighlight solid 1px; 
	border-top       : buttonshadow solid 1px; 
	top              : 1px;
	height           : 22px; 
	width            : 23px;
}

.tb_sep {
	position     : absolute; 
	border-left  : buttonshadow solid 1px; 
	border-right : buttonhighlight solid 1px; 
	font-size    : 0px; 
	top          : 1px;
	height       : 22px; 
	width        : 1px; 
}

.tb_general {
	position         : absolute;
	background-color : #C0C0C0;
	height           : 22px; 
	top              : 2px;
	font             : 8pt Verdana,Arial,sans-serif;
	border           : none;
}

.tb_text_mouseover {
	background-color : #C0C0C0;
	height           : 20px; 
	top              : 2px;
	font-family      : "MS Sans Serif";
	font-size        : 6pt;
	border-bottom    : buttonhighlight solid 1px; 
	border-left      : buttonshadow solid 1px; 
	border-right     : buttonhighlight solid 1px; 
	border-top       : buttonshadow solid 1px; 
	height           : 17px;
}

.tb_handle {
	position         : absolute;
	background-color : <%editor_base_color%>; 
	border-left      : buttonhighlight solid 1px; 
	border-right     : buttonshadow solid 1px;
	border-top       : buttonhighlight solid 1px; 
	font-size        : 1px;
	top              : 1px; 
	height           : 22px;
	width            : 3px;
}

.toolbar {
	position         : relative;
	background-color : <%editor_base_color%>; 
	border-bottom    : buttonshadow solid 1px; 
	border-left      : buttonhighlight solid 1px; 
	border-right     : buttonshadow solid 1px; 
	border-top       : buttonhighlight solid 1px; 
	height           : 25px;
	top              : 0px;
	left             : 0px;
}

private/templates/common/editor_table.html0100666000076400010020000000266307426631645017672 0ustar  alexcvs
Create Table





    
 
    
  Rows:
  
  Cell Padding:
  
 
    
  Columns:
  
  Cell spacing:
  
 
    
  Width
   
	
  
 
    
  Border:
  

    

    

    
	  
	

    
private/templates/common/editor_text.html0100666000076400010020000000272407426631645017565 0ustar  alexcvs
Insert Text Field





    
	
    
		Name:
	
    
	
    
		Initial Value:
	
    
	
    

    


    
	
    
		Width in characters:
		
		Tab Order:
		
	
    
	
    
		Password field:
		Yes
		No
		 
	
    

    

    

    
	  
	

    


private/templates/common/editor_textarea.html0100666000076400010020000000307207426631645020413 0ustar  alexcvs
Insert textarea





    
	
    
		Name:
		
	
    
	
    
		Initial Value:
		
	
    
	
    

    


    
	
    
		Width in characters:
		
		Tab Order:
		
	
    
	
    
		Number of lines:
		
		 
		 
	
    

    

    

    
	  
	

    


private/templates/common/include_css.html0100666000076400010020000000143207453175760017522 0ustar  alexcvs<%--

File
====
include_css.html

Description
===========
The CSS to be included in every single page.

--%>

private/templates/blank.html0100666000076400010020000000015307432766042015021 0ustar  alexcvs




private/templates/bottom.html0100666000076400010020000000155107432602334015232 0ustar  alexcvs

    

    

    <%font%>Status:Please enter the command you wish to execute
    

    <%font%>Command:

    


    private/templates/confirm_delete.html0100666000076400010020000000446307460115747016722 0ustar  alexcvs


    

    

    

    
  
    
                
      
    
        
     
           Confirm  
          
              
          
        
    
      
    
      
    
        
    
            <%font%>
    Do you want to remove all child files and directories in this directories? 
    
        
    
            <%font%>
    <%file_cur%>
    
        

    
            
            
            
            

    
        
    
      
    
    
    

    

    
<%loop list_files%>
    
<%endloop%>














<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>

    

private/templates/copy_status.html0100666000076400010020000000017007401552675016307 0ustar  alexcvs
private/templates/file_editor.html0100666000076400010020000001700107455662063016222 0ustar  alexcvs

FileMan






    
height=100%<%endif%> border="1" cellspacing="0" cellpadding="0" align="center" class="bg_window">
  
    
                 
      
    
        
     
           File Editor:  <%if filename%><%filename%><%endif%>
                 
        
    
      
    
      
          <%if msg%>
          
          <%endif%>
         <%if use_html%>    
            
         <%else%>
            
        <%endif%>
     
                       
          
     
            
                
                    <%if old%>
                    
                    <%else%>
                    
                    <%endif%>                       
                    
    
                     <%font%>
                      <%if writeable%><%else%>(Not Writeable)<%endif%> - 
                      
                      
                      
                      
    
                        <%font%> File name  
                        
                          
                          
                        
                    
    
                
    
                		
          
     
            <%font%><%msg%>
          
    
                <%include file_html_editor.html%>
                
    
                    		
            
    
            
     
               
                    
               
            
              
            
     
              
                
     
                    
    
                        <%font%>                    
                            
                            
                              rows
                              cols
                               
                        
                    
    
                
    
                 		
           
            
        		
  
    

    


















<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>


    


private/templates/file_editor_confirm.html0100666000076400010020000000374007433056251017734 0ustar  alexcvs


    

    

    

    
  
    
         		
      
    
        
     
           File editor confirm 
		  
        
    
      
    
  	  
    
		
    
			<%font%>
    <%filename%> file already exists, do you want to overwrite it?
    
		

    
			
			

    
		
    
	  
    
	
    

    

    
















<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>

    
private/templates/file_html_editor.html0100666000076400010020000000133707443451253017245 0ustar  alexcvs<%if ie_version >= 6%><%endif%>






private/templates/home.html0100666000076400010020000010250607465530512014664 0ustar  alexcvs



File Management 


  
  
  
  
  <body bgcolor="#FFFFFF">
  <p>Fileman requires you to use a frames enabled browser..</p>
  </body>
  



private/templates/login_form.html0100666000076400010020000000327407433056251016067 0ustar  alexcvs

File Manager - Login Form





    

    
	
    
		
    
		  
    
			
			  
    
				
     
				  Login form
				
    
				
    
				  
    
				   <%if msg%><%msg%><%else%>Welcome!! Please enter Username and Password.<%endif%>
					   
						
    						
					  
     
						User name:  
						 
						  
						
					  
    
					  
    Password:  
						 
						  
						
					  
    
					  
     
						 
						  

    
							
						  
    
						    		
					  
    
					
    
					
    
				      		
				
    
			  
    
			    		
		  
    
		
    
	
    

    


    

private/templates/main.html0100666000076400010020000003630507460115742014662 0ustar  alexcvs



    

<%if readme%><%if position eq 'Y'%>
    <%font%><%readme%><%endif%><%endif%>

  <%if search%>
    <%if cmd_do eq "cmd_search" or cmd_do eq "cmd_replace"%>
  
    <%endif%>
  <%endif%>
  
<%if speed_bar%> 
  
<%endif%> 

    <%font%>      
      
            <%status%>
    
           
          
       <%loop results%> 
        class="background"<%else%>class="bg_main"<%endif%>> 
                     
        <%endloop%>
      
    
        
    
           
            
          
          <%font%><%sview%>
          <%font%><%sname%>
          <%font%><%ssize%>
          <%font%><%stype%>
          <%font%><%sdate%>
          <%font%><%suser%>
          <%font%><%sperm%>
        
     
            <%if type%>
                <%if disabled%>
                               
                <%else%>
                               
                <%endif%>
            <%else%>
                 
                
            <%endif%>
            
          
          
          <%if disabled%>
             <%icon%>
          <%else%>
            <%if isdir%>
                
              <%else%>
                
              <%endif%><%icon%>
          <%endif%>       
          
          <%font%>
          <%if disabled%>
              <%name%>
          <%else%>
              <%if isdir%>
                <%name%>
              <%else%>
                <%if show_all%>
                    <%name%>
                <%else%>
                    <%ifnot cmd_edit%>
                        <%name%>
                    <%else%>
                        <%name%>
                    <%endif%>
                 <%endif%>
              <%endif%>
          <%endif%>
          
          <%font%><%if size%><%size%><%else%> <%endif%>
          <%font%><%if type%><%type%><%else%> <%endif%>
          <%font%><%date%>
          <%font%><%user%>
          <%font%>
           <%if disabled%>
              <%perm%>
          <%else%>
            <%if show_all%>
                <%if type%><%perm%><%endif%>
            <%else%>
                <%ifnot cmd_chmod%>
                    <%perm%>
                <%else%>
                   <%if type%><%perm%><%endif%>
                <%endif%>
            <%endif%>
          <%endif%>
            
              
            
    
        		
  
     
      <%font%>Pages:  <%speed_bar%> 
  
    
<%ifnot position%>
<%set position="N"%>
<%endif%>
<%if readme%><%if position eq 'N'%>
    <%font%><%readme%><%endif%><%endif%>


























<%ifnot user_sessions%>

<%endif%>
<%if root_selected%>

<%endif%>
<%if re_scheme%>

<%endif%>

    



private/templates/multi_upload.html0100666000076400010020000001345207433056251016431 0ustar  alexcvs

FileMan






    

    

    
	
    
	  
    
		     		
		  
    
			
     
			   Multiple uploading 
			  
			
    
		  
    
		  

    
			
    		            
			  
     
				<%font%> 1.
				<%font%>
					
					Ascii 
					Binary 
					Auto  
			  
    
			  
     
				<%font%> 2.
				<%font%>
					
					Ascii 
					Binary 
					Auto  
			  
    	
			  
    
				<%font%> 3.
				<%font%>
					
					Ascii 
					Binary 
					Auto  
			  
    	
			  
     
				<%font%> 4.
				<%font%>
					
					Ascii 
					Binary 
					Auto  
			  
    	
			  
     
				<%font%> 5.
				<%font%>
					
					Ascii 
					Binary 
					Auto  
			  
    	
			  
     
				<%font%> 6.
				
					
					Ascii 
					Binary 
					Auto  
			  
    	
			  
     
				<%font%> 7.
				<%font%>
					
					Ascii 
					Binary 
					Auto  
			  
    	
			  
     
				<%font%> 8.
				<%font%>
					
					Ascii 
					Binary 
					Auto  
			  
    	
			  
     
				<%font%> 9.
				<%font%>
					
					Ascii 
					Binary 
					Auto  
			  
    	
			  
     
				<%font%> 10.
				
					<%font%>
					Ascii 
					Binary 
					Auto  
			  
    	

			  
    
				
    
					<%font%>Overwrite  
					
                    
					

    
				    		
                
    
			
    

		  
    
		    		
	  
    
	
    

    














<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>

    


private/templates/preferences.html0100666000076400010020000004711507470753131016241 0ustar  alexcvs
   
FileMan






    

    

    
    
    
      
    
                    
          
    
            
     
               Preferences 
              
            
    
          

    
          <%if msg%>
          
                       
              
    <%font%><%msg%>
    
          
    
          <%endif%>
          
    
              
    
                     
                    
                    <%font%>Default Paths
                    
                
    
                
    
                    
                    
                    
                
    
                
    
                    
                    
                    
                    
                
    
                
     
                    
                                      
                    
                        
                                                         
     
                                <%font%>Password Directory <%ifnot passwd_dir_level%>Root:/<%endif%>
                                <%font%>
                                     (No trailing slash)
                                
                            
    
                            
     
                                <%font%>Working Directory
                                <%font%>
                                    
                                
                            
                 
                        
    
                        		
                    
                
    
                
    
                    
                
       
          
    
          
    
              
    
                     
                    
                    <%font%>Display
                    
                
    
                
    
                    
                    
                    
                
    
                
    
                    
                    
                    
                    
                
    
                
     
                    
                                      
                    
                        
                     
                          
     
                            <%font%>Sort Order
                            
                                
                            
                          
    
                          
     
                            <%font%>Rows per page
                            <%font%>
                                
                                  
                                checked<%endif%> value=on name=showall  onclick="show_default()" > All files
                            
                          
     
                          
     
                            <%font%>Pages per screen
                            
                                
                            
                          
                           
                        
    
                        		
                    
                
    
                
    
                    
                
       
            
    
            
    
              
    
                     
                    
                    <%font%>File display
                    
                
    
                
    
                    
                    
                    
                
    
                
    
                    
                    
                    
                    
                
    
                
     
                    
                                      
                    
                        
                            <%if ie%>
                            
                            <%endif%>
                            
     
                                <%font%>Editor mode
                                
                                                                        
                                
                            
    
                                <%font%>The README's content 
                                
                                    
                                
                            
    
                            
     
                                <%font%>
                                    checked<%endif%>>
                                    Do you want to show hidden files?
                                
                            
                                
                        
    
                        		
                    
                
    
                
    
                    
                
       
            
    
            
    
              
    
                     
                    
                    <%font%>Color & Font
                    
                
    
                
    
                    
                    
                    
                
    
                
    
                    
                    
                    
                    
                
    
                
     
                    
                                      
                    
                        
    
                            
     
                                
                                    
                                        <%ifnot multi%>
                                          
                                        <%endif%>
                                    
    
                                        
    
                                            <%font%>Scheme:
    
                                                                                               
                                                
                                                		
                                        
    
                                        
    
                                            <%font%>Font:
    
                                            
                                            <%font%>

    Refresh the browser if it's Netscape Navigator    
                                                		
                                        
    
                                            
                                                <%font%>Environment
                                            
                                          
    
                                    		                               
                                
                                    
                                
                            
    
                        
    
                        		
                    
                
    
                
    
                    
                
       
            
                        
            
    
            
                                              
              
    
                
                    
                    

    
                    		
              
    
            
    
          
            		
      
    
    
    

    














<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>
    



private/templates/progress_bar.html0100666000076400010020000000476207433056251016427 0ustar  alexcvs<%if confirm%>


    

    

    

    
  
    
         		
      
    
        
     
           Copy confirm 
		  
        
    
      
    
  	  
    
		
    
			<%font%>
    Overwrite: <%to%>
    
		
    
			<%font%>
    with: <%from%>
    
		

    
			
			
			
			

    
		
    
	  
    
	
    

    

    
<%loop results%>
	
<%endloop%>




















<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>

    
<%else%>

<%endif%>private/templates/protect_directory.html0100666000076400010020000000717407433277007017507 0ustar  alexcvs

    



    
	
    
		
			
    
				
    
					<%font%> Commands:
					<%font%>
					<%if show_all%>
					Edit | 
					Download | 
					Copy | 
					Delete | 
					Move | 
					Chmod | 
					Tail | 
					Perl | 
					Diff | 
					Tar
					<%else%>
					<%if cmd_edit%>Edit | <%endif%>
					<%if cmd_download%>Download | <%endif%>
					<%if cmd_copy%>Copy | <%endif%>
					<%if cmd_delete%>Delete | <%endif%>
					<%if cmd_move%>Move | <%endif%>
					<%if cmd_chmod%>Chmod | <%endif%>
					<%if cmd_tail%>Tail | <%endif%>
					<%if cmd_perl%>Perl | <%endif%>
					<%if cmd_diff%>Diff | <%endif%>
					<%if cmd_tar%>Tar<%endif%>
					<%endif%>
					
				
    
			
    
		    		
	
    

    

	<%ifnot delete_list%>
	
	<%endif%>
	
		<%endif%>
	
    
		<%font%>
		<%if pass_path%>
		Password directory is <%pass_path%>
		<%else%>
			Protect <%if work_path%><%work_path%><%else%>Root<%endif%> directory.
		<%endif%>
	
    
		
			
    
				
    
					<%font%>User name: 
					<%font%>Password: 
					
				
    
			
    
		    		
	
    
	
    
		<%font%>
		<%if delete_list%>User name: <%delete_list%> 
		 
		
		<%if pass_path%>
		Password directory is <%pass_path%>
		<%else%>
		Protect <%if work_path%><%work_path%><%else%>Root<%endif%> directory.<%endif%>
    

    



<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>

    private/templates/tar_confirm.html0100666000076400010020000000406407433056251016235 0ustar  alexcvs

    

    

    

    
  
    
         		
      
    
        
     
           Tar confirm 
		  
        
    
      
    
  	  
    
		
    
			<%font%>
    <%file%> file already exists, do you want to overwrite it?
    
		

    
			
			

    
		
    
	  
    
	
    

    

    
<%loop results%>
	
<%endloop%>

















<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>

    private/templates/tar_information.html0100666000076400010020000000752007433246700017125 0ustar  alexcvs


    

    
 
    
	
	
    
  
    
    
              
       <%loop results%> 
        bgcolor='#E9E9E9'<%endif%>>           
		  
        <%endloop%>			
		
    
        
     
		  
		   
          Name
          Size
          Date
		  Owner
		  Permissions
        
    
			
	  		
		  
		  <%font%><%if type eq 5%><%else%><%icon%><%endif%>
          <%font%><%name%> 
          <%font%><%size%> 
          <%font%><%date%> 
		  <%font%><%uid%> 
		  <%font%><%chmod%> 
        
    <%font%>User to extract: <%user%>
    
      
    
        		
  
    

    



















<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>

    


private/templates/user_form.html0100666000076400010020000000601507433056251015731 0ustar  alexcvs
   
FileMan





    

    

    
	<%if msg%>
	
    
		
    <%font%><%msg%>
    
	
    
	<%endif%>
	
    
	  
    
		     		  
		  
    
			
     			  
			 User password
			   
			
    			
		  

    
  		  
    
				
     
					
						
    							
							
    
								<%font%>Old Password: 
								 
									
									
								
							
    
							
     
								<%font%>New Password:
								 
									
								
							
    
						
    
					    		
				
    
				
     
					
    
						
						
						
    
						
    
					    		
				
    
			
    
		  
		    		
	  
    
	
    

    
















<%ifnot user_sessions%>


<%endif%>
<%if root_selected%>

<%endif%>

    

private/templates/view_image.html0100666000076400010020000000126507401552675016054 0ustar  alexcvs

    
	
    
	
	
    
	
    

    





    



private/templates/compiled/0040777000076400010020000000000007477023140014636 5ustar  alexcvs