perl メモ

=========================  catalyst    ====================
I.語境
  1.$c  #$context
  2.$c -> req   #申請
　3.$c -> res   #返事
　4.$c -> config  # root name 設定
　5.$c -> log    
  6.$c -> stash   # データ埋入

II.動作 sub
　1.sub test : Path('my/test'){}   #
  2.sub test : Regex('^my(\d+)/path(\d+)$'){} #
  3.sub test : Global{}     #
  4.sub test : Local {}     #Site::C::My::Path =>
  5.sub test : Private{}
 
  1.sub default : Private{}
  2.sub begin : Private{}   #　小->大　test->my 
　3.sub end : Private{}
  4.sub auto : Private{}   #　大->小  my->test

III.URL処理
　1.　詳細 -> 抽象　
　　　/foo/boo/hoo
　　　/foo/boo
　
　2.　$c -> req -> param('somethimg');
 
IV. Controller　（forward メソッド）
　1.　変数　$c -> forward -> ('test',[qw(test1 test2)]); # データ渡す
  2.　$c -> forward -> ('/my/path/test');
  3.  $c -> forward -> (qw/class method/);
  4.  process()  # default

V.
  　

=========================   UNIVERSAL  ====================
1. UNIVERSAL::isa($obj, 'CLASS'); # $obj is class's ref ?
2. UNIVERSAL::can($obj,'method'); # method is true ?

3. DESTROY 析構
4. AUTOLOAD

=========================  %ENV ============================

while( my ($key,$value) = each %ENV ){
 print "$key -> $value
";
}

======================= @INC ================================

BEGIN { unshift @INC,'D:\xampp\htdocs\modperl\site'; }

====================== 正規表現 ==============================

(exp)   
(?exp)  匹配exp,并捕文本到名称name的也可以写成(?'name'exp)
(?:exp)  匹配exp,不捕匹配的文本，也不此分分配号
(?=exp)  匹配exp前面的位置
(?<=exp)  匹配exp后面的位置
(?!exp)  匹配后面跟的不是exp的位置
(?(?#comment)  #

=================== HTML::TreeBuilder ===================
use HTML::TreeBuilder;
use Data::Dumper;
use utf8;

use Encode;
$html = encode('utf8',decode('sjis',$html));

my $tree = new HTML::TreeBuilder;
$tree->parse($html);
$tree->eof();

foreach my $tag ($tree->look_down('_tag' => 'TR','HEIGHT'=>'24')){
 $data = $tag->as_HTML("<>",":");
 print $data,"\n";
 #print $tag->as_text("\t"),"\n";
}
$tree = $tree->delete;
====================== no search   ==================
robots.txt

User-agent: *
Disallow:/pengyou_list.cgi
Disallow:/py_info.cgi
Disallow:/pengyou.cgi
Disallow:/pengyou_search.cgi
Disallow:/pobox.cgi
Disallow:/pobox2.cgi

======================  XML     =====================
#--------------   read:   ------------#
use XML::Simple;
use Data::Dumper;

my $xmlfile = './amstock_settings.xml';
my $xml = new XML::Simple;
my $data = $xml->XMLin($xmlfile);

for(@{$data->{data_sets}->{data_set}}){
 print "$_->{title}\n";
}

#----------   write:   --------------#
use strict;
use XML::Writer;

require "./camelid_links.pl";
my %camelid_links = get_camelid_data();

my $writer = XML::Writer->new();

$writer->xmlDecl();  #
$writer->startTag('html');
$writer->startTag('body');

foreach my $item ( keys (%camelid_links) ) {
    $writer->startTag('a', 'href' => $camelid_links{$item}->{url});
    $writer->characters($camelid_links{$item}->{description});
    $writer->endTag('a');
}

$writer->endTag('body');
$writer->endTag('html');

$writer->end();

====================== 正規表現　===================
Regexp::Common
=========================

use lib '/xxx/xxx/xxx'

unshift(@INC,"/xxx/xxx/xxx");

====================== Tk 文字　======================

use Encode;
use Encode::CN;
$dat="中文";
$str=decode("gb2312",$dat);
@chars=split //,$str;
foreach $char (@chars) {
print encode("gb2312",$char),"\n";
}

=======================wantarray=======================

sub testreturn{
 if (wantarray) {
  return @array;
 }else{
  return $string; 
 }
}

@arr = testreturn();
$str = testreturn();

========================= photo gif ====================

#!/usr/bin/perl

$file = '/usr/local/etc/httpd/htdocs/images/picture.gif';

print "Content-Type: image/gif\n\n";
open(GIF,"<$file") || die "Can't open GIF\n";
while (read(GIF,$buffer,16384)) {
   print $buffer;
}

========================  GD  ===========================
use GD;

my $im = new GD::Image(1000,1000);

# allocate some colors
my $white = $im->colorAllocate(255,255,255);
my $black = $im->colorAllocate(0,0,0);      
my $red = $im->colorAllocate(255,0,0);     
my $blue = $im->colorAllocate(0,0,255);

$im->line(0,0,150,150,$red);
$im->string(gdSmallFont,2,10,"Peachy Keen",$black);

open(FF,">test.png");
binmode FF;
print FF $im -> png;
close(FF);
======================File::Find==========================

use File::Find;

$ARGV[0] ? $ARGV[0] : '.';
find(\&wanted,"$ARGV[0]");
sub wanted{
 my $filename = $File::Find::name;
 print "$filename\n" if ($filename =~ /$ARGV[1]/); 
}

======================Data::Dumper=========================

use Data::Dumper;

$aa = "123";

print "1---$aa\n";

$dumper = Data::Dumper ->new([$aa],[qw(aa)]);
$value = $dumper -> Dump();
print "$value\n";

$aa = "abc";
print "2----$aa\n";

eval($value);
print $aa;

================================cpan==========================

ppm 更新　

perl -MCPAN -e shell

o conf

o conf urllist push
o conf urllist push
o conf urllist push

 

o conf commit  #保存

----------------xp -----------------
1. C:\Perl\lib\CPAN\Config.pm
2. 'make' => q[C:\VStudio\VC98\bin\nmake.EXE],
3. 

=====================================scan dir============================
sub scanDir {
    my $dir = shift;
    if (-d $dir) {
        my $DH;
        opendir $DH, $dir or warn "Couldn't open directory $dir: $!";
        while (my $file = readdir $DH) {
            next if $file eq '.' || $file eq '..';
            my $fullFileName = $dir . '/' . $file;
            open(FF,">>list.txt");
            print FF "$fullFileName\n";
            close(FF);
            scanDir($fullFileName);
        }
    }
}

scanDir($ARGV[0] ? $ARGV[0] : '.');

=================================check time================================
use Benchmark;
timethis(1000,"aa()"); #　回数=1000　
================================== time ====================================

my @nowtime = localtime(time);
my $year = sprintf("%04D",$nowtime[5] + 1900);
my $month = sprintf("%02D",$nowtime[4] + 1);
my $mday = sprintf("%02D",$nowtime[3]);
my $timenow = "$year$month$mday";

================================ html \s ==================================

$html =~ s/\n/aaa/g;
$html =~ s/\t/bbb/g;
$html =~ s/ /ccc/g;
$html =~ s/\r/ddd/g;
$html =~ s/\f/eee/g;

=================================  utf-8 ==========================

--------------------       wide code          ---------------------
use Encode;

***** input string is utf8 *******
1. my $non_wide_char = encode($charset, $wide_char);

2. my $wide_char = decode($non_wide_char_charset, $non_wide_char);

3. from_to($string, $from_char_charset, $to_char_set);

--------------------       is utf8?         ---------------------
if(utf8::is_utf8($key)){
 binmode STDOUT, ':utf8';
 print "$key is utf8\n";
}else{
 binmode STDOUT, ':utf8';
 print "$key not utf8\n";
}

print utf8::is_utf8("ほげ") ? 'UTF-8 Flag' : 'not UTF-8 Flag';

-----------------------     code   chang               --------------------

use Encode;
gbk->uft-8：
$line = encode("utf-8",decode("euc-jp",$line));
或
$line = encode_utf8(decode("gbk",$line));
utf-8->gbk：
$line = encode("gbk", decode("utf8", $line));
uft-8->gb2312：
$line = encode("gb2312", decode("utf8", $line));

=========================== ENV  =================================
#!/usr/bin/perl

print "Content-type: text/html\n\n";
print "\n";
print "\n";
print "";
print "\n";

foreach (sort keys %ENV) {
print "$_: $ENV{$_}
\n";
}

print " \n";

=====================input===================
perl yu.pl xxxxfile

@ARGV
$ARGV[0]

===============================================================
use Data::Dumper
print Dumper( \%xxx );
Devel::Peek

=========================DBI=======================================
#!/usr/bin/perl
print "Content-type: text/html\n\n";
use DBI;

my $dbh = DBI->connect("DBI:mysql:yu","root","123456",{'RaiseError' => 1});　　
#$dbh->do("CREATE TABLE foo (id mediumint not null auto_increment, name VARCHAR(20),)");

#$dbh->do("INSERT INTO user VALUES ('bbbbb','bb22','b333','f','1999-03-30','2008-01-01')");

#$dbh->do("DROP DATABASE db2");

my $sth = $dbh->prepare("SELECT * FROM user");
  $sth->execute();
  while (my $ref = $sth->fetchrow_hashref()) {
  print "

$ref->{'name'}

\n";
  }
  $sth->finish();

$dbh->disconnect;

説明:　 1.RaiseError 自動的にエラーを捕らえる

特に: 　1.$quotestring = $dbh->quote($string); #   ""とセット
 2.$dbh -> trace(4,log.txt);  # 　0　無効 　エラー情報：1　2 　3 4　->詳細
 3.DBI::neat()とDBI::neat_list()  #   きれいになる neatの最大値400である
 4.DBI::looks_like_number()    #   quoteとセット 
 5.$row =  $sth -> dump_results(80,'\n','-',\*FILE); # maximum field length   line separator    field seoarator  output file handle
 6.? $sth -> bind_param(1,"何々");
 7.

================================  wget==============================

sub getfile{

if(-e "d$year$month$mday.htm"){ unlink("d$year$month$mday.htm"); }

my $cmd = "";
system "/usr/local/bin/wget --timeout=10 --continue --tries=3 --output-document=d$year$month$mday.htm $cmd";
waitpid($pid1,0);
}
==========================================================
@array =qw(a b c b d e b c d b);
$index = 0;
for(@array){
        print "$index " if /b/;
        $index++;
}
======================================================================
20080122可以用
my($year,$mon,$day,) = unpack("A4A2A2",$date);

如果是2008年12月12日
my($year,$mon,$day) = $string=~/(\d+).*?(\d+).*?(\d+)/;

====================================================================
print sort {(split(/<>/,$a))[4] <=> (split(/<>/,$b))[4]} ;
===============sort map====================

open(FF,"test.dat") or die $!;
@by2and3 = map {$_->[0]} sort {$b->[1] <=> $a->[1]} map {[$_,(split(/,/))[2]]} ;

close(FF);
for(@by2and3){
  print;
}

===============================================================

open(FF,"bbsdata.cgi");
@by2and3 = map {$_->[0]} sort {$b->[1] <=> $a->[1]} map {my $date=(split(/<>/))[4]; $date=~s/[^0-9]//g ;[$_,$date]};

close(FF);
for(@by2and3){
  print;
}

============================    ===========================
perl -MHTML::Template -e 'print $HTML::Template::VERSION . "\n"';
perl -MDateTime -e 'print $DateTime::VERSION . "\n"';
perl -MCGI::Session -e 'print $CGI::Session::VERSION . "\n"';
perl -MCGI::Cookie -e 'print $CGI::Cookie::VERSION . "\n"';

================module モジュール===================
#!/usr/bin/perl
package testmodule;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(mysub1,mysub2);
@EXPORT_OK = qw($myvar1,$mysub2);

sub sub1{}
sub sub2{}

==========================================

=========================プレビュー  ==============

=================CGI::SESSION 222-- client=========
#!/usr/bin/perl
print "Content-type: text/html\n\n";
use CGI;
use CGI::Cookie;
use CGI::Session;

$login = new CGI;
$session = new CGI::Session("driver:File",$login,{Directory=>'/tmp'});
$name = $session -> param("username");
$sessid = $session -> id;
print "$name---$sessid\n";

@cookiepairs = split(/&/, $ENV{'HTTP_COOKIE'});
foreach $pair (@cookiepairs){ 
($cookiename, $cookievalue) = split(/=/, $pair);
$cookievalue =~ tr/+/ /; 
$cookievalue =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$cookie{$cookiename} = $cookievalue; 
$cookname = $cookie{'CGISESSID'};
}

print "$cookname---$sessid\n";

=================CGI::SESSION 111-- server=========
#!/usr/bin/perl

use CGI;
use CGI::Cookie;
use CGI::Session;

$login = new CGI;
$loginuser = $login->param('textuser');
$loginpass = $login->param('textpasswd');
$session = new CGI::Session("driver:File",$login,{Directory=>'/tmp'});
$session -> expire("+1m");
$session -> param('username',$loginuser);
$cookie = new CGI::Cookie(-name => 'CGISESSID',
                          -value => $session->id);

if(("admin" eq $loginuser) && ("admin" eq $loginpass)){
 print "location: admin.cgi\n";
 print $login->header(-cookie=>$cookie);
 print "\n"; 
}else{
 checkuser(); 
}

================== colse windows   ========

 

========================コード ==============================

URL エンコード

$str =~ s/(\W)/'%'.unpack("H2", $1)/ego;
$str =~ tr/ /+/;

URL デコード

$str =~ tr/+/ /;
$str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/ego;

=================================================================

sub add_all{
　　　　　　local($sum); #将$sum定??局部?量
　　　　　　$sum=0; #将sum初始化
　　　　　　foreach $_(@_) { #遍?参数列表
　　　　　　　$sum+=$_; #累加?个元素
　　　　　　}
　　　　　　$sum; #返回sum即?和的?
　　　　}
　　　　$sum=88; #$sum的原始??88
　　　　print $sum; #?示$sum的?即88
　　　　$a=&add_all(3,4,5); #$a的??3+4+5即12
　　　　print $sum; #?示$sum的?仍?88

===========cookie1追加設定===============

#!/usr/bin/perl

use CGI qw/:standard/;

use CGI::Cookie;

my $cgi = new CGI;

my $cookie = new CGI::Cookie(
-name    => 'name',
-value   => 'wac',
-expires => '+2M',
);

print "Set-Cookie: $cookie\n";

print $cgi->header(-cookie=>$cookie);
print $cgi->header("text/html; charset=shift_jis");

print "COOKIEsadfasdfasdfasd\n";

================cookie読む==================
@cookiepairs = split(/&/, $ENV{'HTTP_COOKIE'});
foreach $pair (@cookiepairs){ 
($cookiename, $cookievalue) = split(/=/, $pair);
$cookie{$cookiename} = $cookievalue; 
print "$cookie{'bbsname'}\n";
}
 

 

================特定行を削除する==========-

open(INPUT,"while ($ln = ){
 chomp $ln;
 if($ln !~ s/1(.+)/$1/g){
 push (@newdata,join(",",$ln));
 print "$ln\n";
 }
}
close(INPUT);
open (OUTPUT,">admin.dat");
foreach (@newdata){
 print OUTPUT "$_\n"; 
}
close (OUTPUT);

==========require package module=============
1.require
require ("yu.pl");

unshift (@INC, "/u/perldir");

----yu.pl-----
sub 123{

}
1;

2.package

定義：
package yupackage;

呼び出し方：
$yupackage::var;
&yupackage::123;

消す:
no yupackage;

3.module

定義：
package yumodule;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(yufunc1,yufunc2);
@EXPORT_OK = qw($yuvar1,$yuvar2);

呼び出し方；
use yumodule;

消す:
no yumodule;

==========よく使う======

foreach $i (1..10){
 print "$i\n";
}
======入力=====

sub yuwrite{
 for ($line = ,$count =1;$count <=10;$line=,$count++){
  print ($line);
 }
}
&yuwrite;

=====open=====

open(INPUT,"while (){
 print "$_\n";
}
close(INPUT);

=====read======

open(INPUT,"

$read_longer = read INPUT,$char,256;   #read_longer==charの長さ
print "$read_longer\n"; 
print "$char\n";

close(INPUT);

=====OUTPUT======

open(OUTPUT,">test.txt");
for($i=0;$i<5;$i++){
print OUTPUT "$i\n";
}
close(OUTPUT);

=====ファイル中に入力内容を加入する=====

for ($line = ,$count =1;$count <=1;$line=,$count++){
  open(OUTPUT,">test.txt");
  print OUTPUT $line;             # $line==入力内容
  close(OUTPUT); 
 } 

========ファイル中に入力内容を加入してから、内容の長さを表示する=====

sub write_file{
 
 for ($line = ,$count =1;$count <=1;$line=,$count++){
  
  open(OUTPUT,">test.txt");
  print OUTPUT $line;
  close(OUTPUT); 
 
 } 
} 

sub read_file{
 open(INPUT,"

 $read_longer = read INPUT,$char,256;   #read_longer==charの長さ
 print "$read_longer\n"; 
 print "$char\n";

 close(INPUT);
}

&write_file;
&read_file;

===== ファイルを削除する=======
unlink("test.txt");

unlink("test1.txt","test2.txt");

unlink(<*>);          #すべての削除

=====ファイルの名前変更========

rename("old.txt","new.txt");

flock(INPUT,1);    #1,2,4,8

=========open dir =================

opendir (DIR,"test")or die("Cannot OPEN\n");
@filelist=readdir(DIR);
foreach $file(@filelist){
 print "$file\n";
}

=========移動================

chdir("test");
unlink(<*.ppt>);
rmdir("test");