Hatena::Groupperl

Press::Alt_R

2010-07-12

Perlわかば (複数キーのsort)

#!perl

use strict;

my @records = (
{name=>"John" , age=> 10},
{name=>"Jack" , age=> 13},
{name=>"Mary" , age=> 10},
{name=>"Ken" , age=> 12},
{name=>"Bill" , age=> 10},
{name=>"Amy" , age=> 12},
);

my @sorted = sort{
   $a->{age} <=> $b->{age} or $a->{name} cmp $b->{name} 
} @records;

for(@sorted){
  print $_->{age}." ".$_->{name} , "\n";
}

メモ

  • 「A or B」= 「Aを評価」「Aが偽ならorの先へ」「Bを評価」
  • orは 1/0 ではなく、真の場合は評価値をそのまま返す
  • ( (A1 cmp B1) or (A2 cmp B2) ) の値は、全体としては、(1,0,-1) となる通常のcmpと同じ

todo

  • コストの高いソート
  • Schwarzian Transform

2010-07-07

Perlわかば (sort)

わかばと言いつつはまった(またpackで……)

#!perl

use strict;
use Benchmark qw(cmpthese);

my $DATA_FILE = "./ipaddr_list.txt";

# -- read fiile
open my $fh, "<" , $DATA_FILE ||die "cannot open file";
my @lines = <$fh>;
for (@lines) {chomp($_);}
close $fh;

# ---- sort lines via name.. but isn't it slow?

sub sort_via_names{
  my @sort_via_names = 
    map {$_->[0]}
      sort {ipstr_into_num($a->[1]) <=> ipstr_into_num($b->[1])}
        map {[$_, (split(":", $_))[1] ]}
          @lines;
  
  return @sort_via_names;
}

sub sort_via_names_cache{

  my @sort_via_names = 
    map {$_->[0]}
      sort {$a->[1] <=> $b->[1]}
        map {[$_, ipstr_into_num((split(":", $_))[1]) ]}
          @lines;
  
  return @sort_via_names;
}


sub ipstr_into_num{
  my $ipstr = shift;
  my $ipbin = pack('C4' , split(/\./ , $ipstr));
  my $ipnum = unpack('L', $ipbin);
  return $ipnum;
}

print join "\n" , sort_via_names() , "\n";

#cmpthese(1000, {nocache=>\&sort_via_names, cache=>\&sort_via_names_cache});

ポイント

  • sortの判定式の中はできるだけ軽く書かないといけませんよ

2010-07-01

Perlわかば(リスト/map)

#!perl
use strict;

my @list = qw( apple banana cherry dorian);
my @nlist = (10,20,30,40,50,60);
my %hash = ( "a"=> "apple", "b"=>"banana");

my @l_list = map{uc $_;} @list;

print join "\n", @l_list;

2010-04-23

スクリプトを単独実行と外からのテスト両方に対応させる

Rubyの本にも出てくるのにいつも忘れる。__FILE__ね。

if ($0 eq __FILE__){&main();}
exit;

sub main {
  # ...
}

他の言語でも

ちなみに、Python,Ruby,PHPだとこんな感じらしい。

if __name__ == '__main__':
  # do something
if $0 == __FILE__
  # do something
end
if (basename(__FILE__) == basename($_SERVER['PHP_SELF'])) {
    // do something
}

MickeyMickey2011/06/05 16:53Ppl like you get all the barnis. I just get to say thanks for he answer.

xgmmihkzhxgmmihkzh2011/06/05 18:07cg00TQ <a href="http://uslmoqloptuh.com/">uslmoqloptuh</a>

tqvatnymziltqvatnymzil2011/06/06 22:41ZktEYO , [url=http://njulalfrwnyf.com/]njulalfrwnyf[/url], [link=http://muosqitbsubm.com/]muosqitbsubm[/link], http://tnbhtciljgdp.com/

wawzcuowawzcuo2011/06/07 17:57FHCKGw <a href="http://wjmoxpbslwox.com/">wjmoxpbslwox</a>

pmzmcxkcxpmzmcxkcx2011/06/09 19:18dl6rEf , [url=http://fmfywxxznbhl.com/]fmfywxxznbhl[/url], [link=http://mhkowmbmlixm.com/]mhkowmbmlixm[/link], http://jnvnlccelwed.com/

2010-04-22

『初めてのPerl』 Cpt 3..5 練習の回答例

| 15:55

source.txt

wilma
pebbles
bamm-bamm
fred
betty
barney
dino

source_numbers.txt

4
3
6
5
2
4
1
3
2
6
1
1

3-1.

#!perl
use strict;
use warnings;

open(my $fh , "<" , "source.txt") || die("cannot open file");
my @names = <$fh>;
close($fh);

print reverse @names;

dino
barney
betty
fred
bamm-bamm
pebbles
wilma

3-2.

#!perl
use strict;
use warnings;

open(my $fh , "<" , "source_numbers.txt") || die("cannot open file");
my @numbers = <$fh>;
close($fh);

my @namelist = qw(fred betty barney dino wilma pebbles bamm-bamm);
foreach my $number(@numbers){
  chomp $number;
  print "no. $number is: ", $namelist[$number-1] , "\n";
}
no. 4 is: dino
no. 3 is: barney
no. 6 is: pebbles
no. 5 is: wilma
no. 2 is: betty
no. 4 is: dino
no. 1 is: fred
no. 3 is: barney
no. 2 is: betty
no. 6 is: pebbles
no. 1 is: fred
no. 1 is: fred

3-3.

#!perl
use strict;
use warnings;

open(my $fh , "<" , "source.txt") || die("cannot open file");
my @names = <$fh>;
close($fh);

print sort {$a cmp $b} @names;
bamm-bamm
barney
betty
dino
fred
pebbles
wilma

4-1.

#!perl
use strict;
use warnings;

my @fred = qw{1 3 5 7 9};
my $fred_total = &total(@fred);
print "the total of \@fred is $fred_total.\n";

my @one_to_thousand = (1..1000);
my $all_total = &total(@one_to_thousand);
print "the total of \@one_to_thousand is $all_total.\n";

sub total{
  my @numbers = @_;
  my $sum = 0;
  foreach my $num(@numbers){
    $sum += $num;
  }
  return $sum;
}
the total of @fred is 25.
the total of @one_to_thousand is 500500.

Perl Cookbook メモ(Cpt 1: Strings - psgrep)

| 15:28

chapter1の最後のスクリプト読み解き。とりあえずコード貼ってわかる範囲で追記メモ。

(いわずもがなのdisclaimer:追記したことが間違っていることもあります)

元は、PDF版のCookbookからのコピペ。

what is this

psgrep uid < 10

のように、条件を指定して、psコマンドの出力結果から該当行を取り出す。

code

#!/usr/bin/perl -w
# psgrep - print selected lines of ps output by
# compiling user queries into code

# 使い方の例
#  psgrep uid < 10

use strict;
# each field from the PS header

my @fieldnames = qw(FLAGS UID PID PPID PRI NICE SIZE RSS WCHAN STAT TTY TIME COMMAND);
# determine the unpack format needed (hard-coded for Linux ps)
my $fmt = cut2fmt(8, 14, 20, 26, 30, 34, 41, 47, 59, 63, 67, 72);

my %fields; # where the data will store

die << Thanatos unless @ARGV;
usage: $0 criterion ...
Each criterion is a Perl expression involving:
@fieldnames
All criteria must be met for a line to be printed.
Thanatos

# @fieldnamesに書かれた名前で、値を返す関数を作成。
#  $を使わずにアクセスできる。
#  コマンドラインから"uid < 10"のように渡された文字列をそのまま評価するため。

# 作成した関数(クロージャ)は、%fieldsを参照する。

# Create function aliases for uid, size, UID, SIZE, etc.
# Empty parens on closure args needed for void prototyping.
for my $name (@fieldnames) {
  no strict 'refs';
  *$name = *{lc $name} = sub ( ) { $fields{$name} };
  # e.g. &FLAGS = &flags = sub(){$fields{FLAG}}
}

my $code = "sub is_desirable { " . join(" and ", @ARGV) . " } ";
unless (eval $code.1) {
  die "Error in code: $@\n\t$code\n";

  # e.g. eval ("sub is_desirable {uid < 10}". 1)
  #   .1とは:
  #   eval ("CODE".1)の結果は正常な場合1、そうでない場合例外が返る?
  #   evalして→ $@をチェック という手順が省ける
}


open(PS, "ps wwaxl |") || die "cannot fork: $!";

# 先頭行を1行だけ先に取り出し(そうか!)
print scalar <PS>; # emit header line

# フォーマットに従って切り出した文字列をtrim
# is_desirableに格納されている比較(fieldsにアクセス)
# 比較した結果が真なら、現在行をprint

while (<PS>) {
  @fields{@fieldnames} = trim(unpack($fmt, $_)); # @hashslice{@keys} = LIST;
  print if is_desirable( ); # line matches their criteria
}
close(PS) || die "ps failed!";

# ================= subroutines

# convert cut positions to unpack format

# e.g. "A8A6A6...."のようなフォーマット文字列

sub cut2fmt {
  my(@positions) = @_;
  my $template = '';
  my $lastpos = 1;
  for my $place (@positions) {
    $template .= "A" . ($place - $lastpos) . " ";
    $lastpos = $place;
  }
  $template .= "A*";
  return $template;
}
sub trim {
  my @strings = @_;
  for (@strings) {
    s/^\s+//;
    s/\s+$//;
  }
  return wantarray ? @strings : $strings[0];
}

# 以下、psコマンドの出力サンプル

# the following was used to determine column cut points.
# sample input data follows
#123456789012345678901234567890123456789012345678901234567890123456789012345
#         1         2         3         4         5         6         7
# Positioning:
#       8     14    20    26  30  34     41    47          59  63  67   72
#       |     |     |     |   |   |      |     |           |   |   |    |
__END__
 FLAGS UID   PID  PPID PRI  NI   SIZE   RSS WCHAN       STA TTY TIME COMMAND
   100   0     1     0   0   0    760   432 do_select   S   ?   0:02 init
   140   0   187     1   0   0    784   452 do_select   S   ?   0:02 syslogd
100100 101   428     1   0   0   1436   944 do_exit     S    1  0:00 /bin/login
100140  99 30217   402   0   0   1552  1008 posix_lock_ S   ?   0:00 httpd
     0 101   593   428   0   0   1780  1260 copy_thread S    1  0:00 -tcsh
100000 101 30639  9562  17   0    924   496             R   p1  0:00 ps axl
     0 101 25145  9563   0   0   2964  2360 idetape_rea S   p2  0:06 trn
100100   0 10116  9564   0   0   1412   928 setup_frame T   p3  0:00 ssh -C www
100100   0 26560 26554   0   0   1076   572 setup_frame T   p2  0:00 less
100000 101 19058  9562   0   0   1396   900 setup_frame T   p1  0:02 nvi /tmp/a

techniques

if ($foo = eval ("100;&baz;" .1)){print "true"}else{print "false"}
$dispose_firstline = scalar <FH>;
 *$name = *{lc $name} = sub ( ) { $fields{$name} };

todo

  • プロトタイプを理解してません