given @Examples[1] when Perl6

19 May 2005


本来写好了的,不小心按了什么快捷键就没了。damn it!

given 开关语句

given-when 是种开关语句(经常有人问 Perl 5 中有没有开关语句,没有开关语句但有个 Switch 模块)。它有点类似于其他语言的 switch-case, 但更强大。(匹配可以是正则表达,函数等)。
一个简单的例子:
given $i { # 这里的 $i 可以是表达式也可以是函数等
    when ($_ != 2) { print '$i isnot 2'; }
    when 1 { print '$i is 1'; }
    print 'b';
    when &foo($_) { print '&foo($i) return true'; }
    when m/^^a/ { print '$i is start with a'; }
    default { print 'default output'; }
}
几点说明:
  1. when VALUE 其实是 when $_ ~~ VALUE 的缩写
  2. default 必须放在所有 when 之后。因为 default 是在所有 when 不匹配后才执行。当然你也可以没有 default
    default 的作用等同于 when ture { ... }
  3. 如果匹配了一个 when, 那么 when 下面的语句将不会执行,匹配后直接跳出。所以这里的 when 1 不会被执行(被上一句执行后跳出了)。
  4. given 块的执行顺序与普通块一样,块里允许存在 when 之外的东西(比如这里的 print 'b';)。
    当 $i 不为 2 时输出 $i isnot 2 而不执行print 'b'; 当为 2 时,按顺序会执行 prin 'b';
  5. when 总是智能匹配 $_, 不管是不是在 given 中。(它可以在 for, while, CATCH 等中存在,只要有 $_ 就可以使用 when)。代码例子:
    for (qw(1 2 3)) {
        when 1 { say '1'; }
        when 3 { say '3'; }
        default { say 'not 1, not 3'; }
    }
    最后的结果为 1(换行)not 1, not 3(换行)3(换行)
    pring 与 say 的区别在于 say 会在后面输出 \n
  6. 我们可以使用 break 来跳出当前 when 和当前块。注意 break 只能在 when 里面而不是外面。例如:
    given $i {
        when 1 {
            print "1";
            break;
            print "11"; # 这句不会被输出,因为 break 跳出了整个循环
        }
        #break; # 出错,break 不能在 when 外面
        default { print "default output"; }
    }
    当 $i 为 1 时输出 1,而没有 11
  7. continue 用来跳出当前 when 而继续执行下一语句(没有跳出当前块)。例如:
    given $i {
        when 2 {
            print "2";
            continue;
            print '22'; # 这句不会被输出,因为 continue 跳出了这个 when 2
        }
        default { print "default output"; }
    }
    当 $i 为 2 时输出 2default output.
  8. 在 for 循环中, break 只跳出当前循环而进入下一循环(不是跳出整个 for 循环)。如果你要跳出整个循环,可以使用 last。我们可以用 next 来代替 break, 因为它表达意思更清晰。
    for (qw(1 2 3)) {
        when 1 {
            say '1';
            break; # next is better
            say '11'; # 这句不会输出
        }
        when 2 {
            say '2';
            last;
        }
        when 3 {
            say '3';
        }
        default { say 'default output'; }
    }
    当 $_ 为 1 时输出 1 (没有输出 11);当为 2 时输出 2 并且执行 last, 所以 when 3 不会被执行。
  9. 如果你使用的带名字的 for 循环,那么第一个带名字变量别名于 $_
    my @foo = (1,2,3);
    for @foo -> $foo { # 后面的 when 里的 $_ 就别名于 $foo
    for @foo -> $foo1, $foo2 { # 后面的 when 里的 $_ 别名于 $foo1
    

eval && try

在 Perl 5 中 eval 不仅能运行字符串也能运行块,而在 Perl 6 中 eval 只能运行字符串,块的话我们用 try 来运行。而错误变量将不再是 $@, 而统一变为 $!
my $a = 0;
eval('$a = 1 / $a');
print $! if $!; # Illegal division by zero

try {
    my $x = 1;
    my $x = 0; # $x 不能定义两次
    CATCH {
        say $!;
    }
}

Correct me if I'm wrong

See u next time.

@Examples[0] is Perl6

19 May 2005


想写点 Perl 6 的东西,却不知道从哪写起,只好写一步算一步了。

子程序参数传递

在 Perl 5 中一般来说都用如下代码获得子程序的参数:
sub foo {
    my ($a, $b) = @_; # or my $self = shift;
在 Perl 6 中
  • 我们可以这么写
    sub foo ($a, $b) {
  • 也可以这么写
    sub foo {
        ($^a, $^b).say;
    }
    &foo(11,22); # print 1122
    $^a 得到第一个参数,$^b 得到第二个参数。猜测下如下是什么结果:
    sub foo {
        ($^c, $^b).say;
    }
    &foo(11,22);
    结果是 2211, 在闭包里所以以 $^ 开头的变量按 Unicode 码排序依次获得参数。(这里的变量可以是 $^cc, $^1y 等)
    我们管这种方式为 placeholder arguments, 中文翻译为“占位符参数”。
  • 如果是匿名函数的话还可以这么写
    my $func = -> $a, $b { print $a,$b };
    $func.(11,22);

for 循环语句

foreach 将不再被使用。 Perl 6 中 for 语句一般这么写:
for @foo {...}
这跟 Perl 5 中没有区别。另一种为:
for @foo -> $item { print $item }
-> 这种写法是种很强大的写法。
  1. 一次取多个变量,例如:
    my @foo = (1,2,3);
    for @foo -> $item1, $item2 {
        print $item1, $item2, '-';输出为 12-3-
    }
  2. 历遍一个 Hash 的写法:(%hash.kv 是将 %hash 变为一个列表,($key1, $value1, $key2, $value2, ...)
    for %hash.kv -> $key, $value { print "$key => $value\n" }
  3. 多个数组写法:(这在 Perl 5 中要用两个 for 才行)
    for zip(@a;@b) -> $a, $b { print "[$a, $b]\n" }
    # or for @a ¥ @b ¥ @c -> $a, $b, $c { print "[$a, $b, $c]\n" }
    
    ¥ 是 zip 的操作符。

最后值得注意的是

for @foo -> $item { print $item }
这种写法里 $item 是只读的,不是可写的。如果想要在块里改变 $item 的值,必须在后面加上 is rw (rw 是可读写 readwrite 的缩写)
my @foo = (1,2,3);
for @foo -> $item is rw {
    $item ~= 'a'; # 连接字符串以前用 $a . $b, 现在要用 $a ~ $b 了
    print $item;
}
而 for @foo { ... } 中 $_ 默认为可读写,也就是说它等同于 for @foo -> $_ is rw { ... }

Correct me if I'm wrong

Enjoy!

Synopsis localization

19 May 2005


Perl6 is not so popular in China as I expected. and I think Perl5 will not die within ten years + Perl6 still need 1~2 years to grow up.

I attended a project named "Perl6 localization"(p6l10n). It translate the Perl6|Synopsis into Chinese.
sounds great, but I should blame myself for being so lazy && patience-less. I haven't make any further step in last few months.

I'm always like that. Full of enthusiasm at beginning and my passion lostes when time passes.
I'm always regretful for this.

Now I pick up the translation of Synopsis.
God bless me.


获取 IRC logger 里的链接

18 May 2005


PerlChina 的 IRC 位于 irc://irc.freenode.net/perlchina
因为我不能长时间在线,又不想错过什么精彩链接,就写了这份代码来解析 IRC log 里的链接。
代码位于 http://www.fayland.org/scripts/irc_link.pl.txt

代码解释

首先 IRC log 的地址都是变动的,比如今天 irclogger 的地址为 http://koala.ilog.fr/twikiirc/bin/irclogger_log/perlchina?date=2005-05-18,Wed 明天后缀又会改。
所以我们先用 DataTime 来拼凑这个 URL.
my $dt = DateTime->now;
my $url = 'http://koala.ilog.fr/twikiirc/bin/irclogger_log/perlchina?date=' . $dt->ymd . ',' . $dt->day_abbr; # like 2005-05-18,Wed
$dt->ymd 得到类如 2005-05-18 格式,而 $dt->day_abbr 得到星期的简写。

第二是使用 LWP 获取网页,因为这个 irclogger 需要验证,所以代码稍微复杂了点。
use LWP;
use vars [email protected]'; # for get_basic_credentials
@ISA = 'LWP::UserAgent';
my $agent = __PACKAGE__->new;
my $request = HTTP::Request->new(GET => $url);

my $response = $agent->request($request);
$response->is_success or die $response->message;

sub get_basic_credentials {
    return ('perlchina', 'perlchina'); # the perlchina irc log site's username&password
}
这里我们重载了 LWP::UserAgent 的 get_basic_credentials 函数。这样就能通过基本的 Web 验证了。

最后获取连接,我没有使用现成的模块,而是用强大的 HTML::Parser 来解析出链接。
use HTML::Parser;

my $parser = HTML::Parser->new(api_version => 3);
$parser->handler(start => \&got_links, 'tagname, attr');
$parser->parse($response->content);
$parser->eof;

sub got_links {
    my ($tagname, $attr) = @_;
    if ($tagname eq 'a' && $attr->{href} && $attr->{href} !~ /^[\/\?]/) {
        print '<a href=\'', $attr->{href}, '\'>', $attr->{href}, '</a><br />';
    }
}
$attr->{href} !~ /^[\/\?]/) 是忽略掉以/和?开头的链接(这些是那页面的内部链接)。
详细的代码解释就免了,perldoc 里都有简单的例子。

So, Enjoy


Ajax && encodeURIComponent

15 May 2005


今天闲着无事就想着用 Ajax 实现论坛的用户名检测。

先简化了下 Ajax.js, 让它能在不同的程序里指定不同的 url, param 和 div 的 id.


var req, Div;
var debug = 0;

function Ajax(DivName, url, parameters) {
    if (window.XMLHttpRequest) req = new XMLHttpRequest();
    else if (window.ActiveXObject) req = new ActiveXObject("Microsoft.XMLHTTP");
    else return; // fall on our sword
    req.onreadystatechange = processReqChange;
    req.open("POST", url, true);
    req.setRequestHeader('Connection', 'close');
    req.setRequestHeader('Content-type', 'application/x-www-form-urlencoded');
    req.send(parameters);
    Div = document.getElementById(DivName);
}

function processReqChange() {
    // only if req shows "complete"
    if (req.readyState == 4) {
        // only if "OK"
        if (req.status == 200) {
            // show content in div
            Div.innerHTML = req.responseText;
        } else {
            if (debug) alert('status is not 200,but ' + req.status);
        }
    }
}
调用的代码为:
<input type="text" maxlength="12" name="username" onblur="CheckName(this.value)"> * 2 - 12 字符(1 - 6 汉字)
<script language="javascript" type="text/javascript" src="./js/Ajax.js"></script>
<script language="javascript" type="text/javascript">
    function CheckName(aObj) {
        try { Ajax('CheckName', 'CheckName.pl', 'mode=Ajax&name=' + encodeURIComponent(aObj)); }
        catch (e) { return; }
    }
</script>
<div id="CheckName"></div>
Update: 感谢 easunlee 的提醒, encodeURIComponent 对 IE5.5 以下无效,所以我们用了 try+catch 在无效情况下不调用该函数(和|或者)弹出 alert 提示升级浏览器。

问题出现了

首先解释下 encodeURIComponent 的作用:将文本字符串编码为一个有效的统一资源标识符 (URI)。
为什么要用这个是因为我想把 username 整个当做参数传递给 CGI, 而不让 CGI 将 username 分割掉。这话听不明白的话我换种方式来说,如果 username = 'a&foo=boo' 而不用 encodeURIComponent 的话,整个参数就成了 name=a&foo=boo, 这样 CGI 就获得两个参数 name 和 foo. 这不是我们想要的。
Javascript 里还有个同样功能的函数 encodeURI, 但是此方法不会对下列字符进行编码:":"、"/"、";" 和 "?"。

刚开始我都输入英文检测代码是否运行正常,后来因为我不想用户名为“客人”,所以就试了下。
结果很令我奇怪,div 为 CheckName 里的输出是“瀹汉”。
一看到这个,第一反应就是编码问题。

客人经过 JS 的 encodeURIComponent 转化后得到的值为 %E5%AE%A2%E4%BA%BA, 而我直接在浏览器里输出客人后转的值为 %BF%CD%C8%CB. 辨别后,猜测 Javascript encodeURIComponent 将“客人”转为了 utf-8 编码。

于是在 CheckName.pl 里加了编码转换。

use Encode qw/from_to/;
my $name = $q->param('name');
from_to($name, "utf8", "gb2312");
终于搞定。

The last words

希望对碰到同样问题的各位能有所帮助。 Have fun!

SVK 安装

14 May 2005


http://svk.elixus.org.nyud.net:8090/?SVKWin32

可以由上述地址下载二进制包,也可以跟我一样按照步骤一步步安装。
  1. 首先得确定你安装了 PerlSubversion 1.13
  2. 下载 http://subversion.tigris.org 里的 Subversion 的 perl 开发包。(目前为 svn-win32-1.1.3_pl.zip,地址在 http://subversion.tigris.org/files/documents/15/19982/svn-win32-1.1.3_pl.zip
    • 将压缩包里的 libsvn_swig_perl-1.dll 拷贝到你 Subversion 的安装目录下的 bin 目录里。(eg: C:\Program Files\Subversion\bin\)
    • 将 swigpl.dll 拷贝到你 perl 安装目录的 bin 目录下。(eg: C:\usr\bin)
    • 在 $Perl\site\lib 目录下建立一个 SVN 目录,将压缩包里的 *.pm 拷贝过去。
    • 在 $Perl\site\lib\auto 目录下建立新目录 SVN,对应压缩包的所有 _(*).dll 分别对应到 $1 目录下。比如 _Client.dll 到 $Perl\site\lib\auto\SVN\_Client 目录下, _Core.dll 拷贝到 _Core 目录,等等。
    有位好人提供了 SVK 所需的 SVN 和其他模块的压缩包。你可以不用做上面这些步骤了。
    http://www.systemex.net/files/svk/svk-0.30-win32-bin.zip
  3. 最后一步 cpan SVK
    安装了一系列模块后就成功了。

svk 的使用以后再介绍。等不及可以到 http://svk.elixus.org.nyud.net:8090/ 找 Tutorial.
have fun!


split

13 May 2005


今天在 perl6.language 里看到一个 split /(..)*/, 1234567890 帖子。发现自己对 split 还是不太熟悉,真是晕一下。

做几道简单的测试题,看看你是否真的懂 split?
  1. print join ",", split /(..)/, 123456;
  2. print join ",", split /(..)/, 12345;
  3. print join ",", split /(..)+/, 123456;
  4. @fields = split /(A)|B/, "1A2B3";
答案分别为:
  1. ,12,,34,,56
  2. ,12,,34,5
  3. ,56
  4. # @fields is (1, 'A', 2, undef, 3)

翻译下 perlfunc 里的 split 那一段并且加点代码佐料,Enjoy.

Translation of "perldoc -f split"

split /PATTERN/,EXPR,LIMIT
split /PATTERN/,EXPR
split /PATTERN/
split

Splits the string EXPR into a list of strings and returns that list. By default, empty leading fields are preserved, and empty trailing ones are deleted. (If all fields are empty, they are considered to be trailing.)

分割字符串 EXPR 为字符串列表并且返回这个列表。默认我们会保留前面的空字段而删除后面的空字段。(如果所有的字段都为空,它们都被认为是后面的空字段。)

In scalar context, returns the number of fields found and splits into the @_ array. Use of split in scalar context is deprecated, however, because it clobbers your subroutine arguments.

在标量上下文,返回字段的个数并且将列表放到默认数组 @_. 但是这是不可取的,因为它可能会影响子程序的参数。

my $count = split /A/, 'BACAD';
print $count, join(",", @_); # 在标量上下文,返回字段个数 $count = 3, @_ = ('B', 'C', 'D')

If EXPR is omitted, splits the $_ string. If PATTERN is also omitted, splits on whitespace (after skipping any leading whitespace). Anything matching PATTERN is taken to be a delimiter separating the fields. (Note that the delimiter may be longer than one character.)

如果没有提供 EXPR ,将使用默认标量 $_. 如果也没有提供 PATTERN, 默认使用空白(所有 EXPR 前面的空白都会被跳过)。任何匹配 PATTERN 的将被作为定界符来分割字段。(注意定界符可能长于一个字符。)

# 这段话代码解释就是
$_ = "  A  B";
print join ',', split;
# 首先将 $_ 作为 EXPR, 空白作为 PATTERN, EXPR 前面的空白都被跳过。所以结果为:A,B
print join ',', split /AA/, 'CCAABBAADD';
# AA 被匹配,所以 AA 是定界符(长于一个字符)。结果为:CC,BB,DD

If LIMIT is specified and positive, it represents the maximum number of fields the EXPR will be split into, though the actual number of fields returned depends on the number of times PATTERN matches within EXPR. If LIMIT is unspecified or zero, trailing null fields are stripped (which potential users of pop would do well to remember). If LIMIT is negative, it is treated as if an arbitrarily large LIMIT had been specified. Note that splitting an EXPR that evaluates to the empty string always returns the empty list, regardless of the LIMIT specified.

如果我们指定了正的 LIMIT, 它表示我们最多分割 EXPR 为 LIMIT 个字段,即使实际上返回的字段个数取决于 EXPR 匹配 PATTERN 的次数。如果没有指定 LIMIT 或者为零,去掉最后的 null 字段。如果 LIMIT 是负的,我们当作指定了个任意大的 LIMIT. 注意分割一个空的 EXPR 字符串时总返回空白列,而不管指定了什么 LIMIT.

print join ',', split /A/, 'BACADAF', 2;
# 因为指定了 LIMIT 为 2,所以即使它可能用 A 分割成四个字段,但它还是就分割了两个字段。
# 输出为:B,CADAF

....

Empty leading (or trailing) fields are produced when there are positive width matches at the beginning (or end) of the string; a zero-width match at the beginning (or end) of the string does not produce an empty field.

如果在字符串的头部或尾部有一次正宽度(界定符长度)的匹配,那么会产生一个头部或尾部的空字段。零宽度的匹配不会产生空字段

print join ',', split /A/, 'ABAC';
# 因为字符串头部匹配了,所以列表的第一个字段为空字段,结果为:,B,C
print join ',', split //, 'BACA';
# 因为匹配的为零宽度,所以没有空字段,结果为:B,A,C,A

....

If the PATTERN contains parentheses, additional list elements are created from each matching substring in the delimiter.

如果 PATTERN 里包含括号,那么每一个匹配的定界符子字符串都会作为元素加到列表中去。

print join ',', split /(A)/, 'BACAD';
# 因为有括号,所以 A 也成了列表的元素。结果为:B,A,C,A,D

....

As with regular pattern matching, any capturing parentheses that are not matched in a split() will be set to undef when returned:

当括号与其他正则模式匹配一起时,如果匹配的不是任何捕获的括号而是其他时,那字段将设置为 undef 返回:

@fields = split /(A)|B/, "1A2B3";
# @fields is (1, 'A', 2, undef, 3)

Explaination

这东西挺难解释的,姑且知道结果就好吧。最起码我是不太解释的了每一条。
my @_ = split /(A)/, 'A'; # @_ = ('', 'A');

print join ",", split /(A)/, 'AAAA', 2; # ,A,AAA
print join ",", split /(A)/, 'AAAA', 3; # ,A,,A,AA
print join ",", split /(A)/, 'AAAA';    # ,A,,A,,A,,A

print join ",", split /A/, 'AACAA'; # ,,C
print join ",", split /(A)/, 'AACAA'; # ,A,,A,C,A,,A

The last word

如翻译有误,敬请指正。另外欢迎交流。Have fun!

Javascript: Events

10 May 2005


问题

用过 QQ 的人都熟悉用 Ctrl+Enter 来发送信息。
网上大部分论坛程序都支持用 Ctrl+Enter 发表帖子,不过当我使用 Firefox 时,大部分论坛(我知道的都不成)这个功能都实效了。
跟 Joe 在 IRC 里说起 Gmail 的 hotkey, 发现在 Firefox 里也是可以使用的。不过找不到 Gmail 的源代码,还好可以用 Google

解决方案


<script type="text/javascript">
var x,q;

function ctlent(e){
  if (document.all){
    x = window.event.keyCode;
    q = event.ctrlKey;
  } else {
    x = e.keyCode;
    q = e.ctrlKey;
  }
  if (q && x==13) {
    this.document.FORM.submit();
    this.document.FORM.Submit.disabled = true;
  }
  if (!document.all){
       window.captureEvents(Event.KEYPRESS);
       window.onkeypress = ctlent;
  }else{
       document.onkeypress = ctlent;
  }
}

function submitonce(form){
    for (var i=0;i<form.elements.length;i++) {
        var e=form.elements[i];
        if(e.type.toLowerCase()=="submit") e.disabled=true;
    }
}
</script>
<form name="FORM" onSubmit="submitonce(this)">
<textarea cols=75 name=inpost onKeyDown="ctlent(event)" rows=7></textarea>
<INPUT name="Submit" type=submit>
</form>

Refer


Day [05.5.10] China.pm.org

10 May 2005


Finally I'm back from ZhengZhou. It's a happy time there with my dear girl friend.

Now I'm the maintainer of China.pm instead of tsingson. But I'm not sure what sure be added in this site. The primary reason of requesting this pm is to get the maillist. It's a great maillist powered by mailman, but we still have some encoding error.

The first idea in my brain is to build a meeting announcement system. It fits the meaning of pm.org(Perl Mongers). Sadly the pm.org doesn't provide any cgi privilege and it's hard to maintain by hand.
The next idea is to build a city/location contact-list, so the perl monger in the same city can have more talk and meetings. with the same reason, I give up.

Qiang said we shouldn't pay our attention on pm.org, PerlChina.org is enough. That makes sense.
Any one has any idea?


$Class[2] = 'Class::Trigger';

28 April 2005


bubble

Trigger 翻译成中文可以是“扳机”,或者将它当成一个控制开关(Bloves 认为“触发器”比较妥当,我也认可。:)。
大多数据库都提供 TRIGGER, 比如 SQLite 就有类如这样的代码:
CREATE TRIGGER insert_exam_timeEnter AFTER  INSERT ON exam
BEGIN

UPDATE exam SET timeEnter = DATETIME('NOW')
         WHERE rowid = new.rowid;
END;
这样在每次插入新数据后就会自动更新 timeEnter 为现在时间。

Class::Trigger - Mixin to add / call inheritable triggers
Class::Trigger 的作者和 Class::DBI 的当前维护者是同一个人,所以在 Class::DBI 中作用非常大。

Example

最简单的例子请先看 perldoc Class::Trigger
而 Class::DBI 中例子请搜索 http://www.class-dbi.com

这里我们举个不太有用的例子:
我们有一个模块Foo,它有一个函数 handle, handle 在程序A中调用时要把参数里的数字去掉并且输出它,而在程序B中要把参数里的字母去掉但不输出它。(不要怪我们的例子奇怪,有时候你会碰到更奇怪的要求。)
这要求的解决方案有好几种,比如

  1. 在 Foo 的 handle 中判断是哪个程序调用并相应修改。这方案不好,会造成代码冗长而不易扩展。
  2. 另一种方案是在程序 A|B 调用 handle 前对传递的参数做相应修改。但是这对于输不输出却无能为力。
而用 Class::Trigger 来解决的话很方便,而容易扩展定制。
package Foo;
use Class::Trigger;

sub new {
    bless {} => shift;
}

sub foo {
    my ($self, $param) = @_;
    $self->call_trigger('validate', \$param);
    # we use $param to do something
}
# 程序 A
Foo->add_trigger(validate => \&sub1); 这里将被继承

my $foo = Foo->new;
$foo->foo("aa11"); # before is aa11, after is aa

sub sub1 {
    my ($self, $param) = @_;
    print "before is $$param, ";
    $$param =~ s/[0-9]+//g;
    print "after is $$param";
}
# 程序 B
my $foo = Foo->new;
$foo->add_trigger(validate => \&sub1); # 这里将不被继承
$foo->foo("aa11"); # before is aa11, after is 11

sub sub1 {
    my ($self, $param) = @_;
    $$param =~ s/[a-z]+//g;
}
关于 Class::Trigger 的继承我简单的写一下,更多的参考 perldoc Class::Trigger 和 perldoc Class::DBI

Enjoy!