Win32下的Perl,无用的select,停滞的Tk,结束吧....
package require Expect
set params [open params.txt r]
array set params_arr [list ]
while {![eof $params]} {
set line [gets $params]
if [regexp {\[(.*)\](.*)} $line full name value] { set params_arr([string trim $name]) [string trim $value] }
}
close $params
proc q3526e {arr} {
upvar $arr params
set buffer [list ]
if [catch {spawn telnet $params(hostname)} result] { puts $result; exit 1 }
expect -re {Password} { exp_send "$params(password)\r" } eof { exit 1 }
expect -re $params(prompt) { exp_send "sup\r" }
expect -re {Password} { exp_send "$params(password)\r" } eof { exit 1 }
expect -re $params(prompt) { exp_send "dis log\r" }
expect -re {More ----} {
foreach ele [split $expect_out(buffer) "\n"] { lappend buffer $ele }
exp_send "\r"
while { [regexp {More ----} $expect_out(buffer)] } {
expect -re {More ----} {
foreach ele [split $expect_out(buffer) "\n"] { lappend buffer $ele }
exp_send "\r"
} -re "$params(prompt)" {
foreach ele [split $expect_out(buffer) "\n"] { lappend buffer $ele }
writelog buffer
exp_send "\r"
} eof { exit 1 }
}
} -re $params(prompt) {
foreach ele [split $expect_out(buffer) "\n"] { lappend buffer $ele }
writelog buffer
exp_send "\r"
} eof { exit 1 }
}
proc writelog {buf} {
upvar $buf buffer
set curr [clock format [clock seconds] -format %D]
regexp {([0-9]{2})/([0-9]{2})/([0-9]{2})} $curr match month day year
set curr "20$year$month$day"
set log [open [format "%s_%s%s" {c:/3526log} $curr {.txt}] w]
foreach ele $buffer { puts $log $ele }
flush $log
close $log
}
if [catch {eval [string trim $params_arr(act)]} result] {puts $result; exit}
参数文件:
[hostname]网关ip地址
[password]交换机密码
[prompt]<Q3526E>
[act]q3526e params_arr
Sqlite
中借鉴了
oracle
、
db2
以及
postgresql
中得
null
操作方法,也就是借由
coalesce
的方法来处理
null
类型的数据。当遇到返回
null
数据时,
coalesce
将第二个参数代替
null
。举例如下:
有表
phones
:
create table phones(name text, number integer);
insert into phones values(‘josh’, 86123413);
insert into phones values(‘mariah’, 89804517);
insert into phones values(‘samantha’, NULL);
很不幸,
samantha
的办公室还没有装电话,所以在表里虽然有她的名字但只能用
NULL
来做填充。如果有人希望在该数据库中查询她的电话时,将得到一个
NULL
的数据。当然首先是要设置
null
的表示字符串,通常情况下我们使用
’NULL’
来表示。为了更清楚地表达这种不存在的状况就需要使用
coalesce
。
Select coalesce(number, ‘no phone number for ’||name) as number from phones where name = ‘samantha’;
这样的查询可以得到合适的结果。至此似乎一切顺利,可事实上却忽视了一种最基本的情况。
Select coalesce(number, ‘no phone number for ’||name) as number from phones where name = ‘tata’;
公司里大概是没有一个叫
tata
的人,也许我们甚至难以确定他的性别。可是即便使用了
coalesce
也将一无所获。
Sqlite
里就是这样的,相关的文档里没有作出很好的解释。但它的确是返回了一个
NULL
值的,这个可以使用
nullif
来得到证实。
Select nullif((Select number from phones where name = ‘tata’), NULL) as result;
还好可以确定它返回了一个
NULL
,只要将
nullif
嵌到
coalesce
中便可以得到希望的结果了。
Select coalesce(nullif((Select number from phones where name = ‘tata’), NULL) , ‘no such person’) as result;
Sqlite
是一个只有几百
k
大小的、
优秀的嵌入式数据库,本身不带有远程连接的功能。由于其身材小,速度快并且为众多的语言支持,所以在单机领域得到了广泛的使用。但由于天然不支持服务
/
客户端的模式,使其在遇到小型规模数据库远程连接的情况时不得不借助于附加的编程。
单位有三百多人,作为网管每天要接到很多电话,有很多一时无法想起对应的名字,翻查通讯录不仅速度慢而且容易漏过。为了方便起见,在
sqlite
上建立了一个通讯录数据表,然后用
perl
编写了一个查询脚本。效果不错的同时,也有同事希望可以得到一份拷贝。但是这时遇到一个问题,如何保证通讯录在不同人手中保持版本的统一性。最好的办法是建立一个服务
/
客户端的模式,在本机上维护一个数据库,而其它人通过连接数据库得到相关的查询结果。
具体的解决方法是这样的:在本机上维护一个到
sqlite
数据库的连接并建立一个来自于客户端的
socket
的监听,接受远程查询条件并回复查询结果;客户端志负责发送和接受这些最简单的任务。
客户端的代码:
use strict;
my $in_buffer = undef;
my $PF_INET = 2;
my $port = 2345;
my $remote_addr =
pack('SnC4x8',$PF_INET,$port,192,168,138,228);
my $SOCK_DGRAM = 2;
socket(UDP_CLIENT, $PF_INET, $SOCK_DGRAM,
getprotobyname('udp'));
while(1){
print("
输入名字或号码:
");
my
$out_buffer=<STDIN>;
chomp($out_buffer);
if($out_buffer
eq "exit"){last;}
send(UDP_CLIENT,
$out_buffer, 0, $remote_addr);
print("waiting
for reply...\n");
recv(UDP_CLIENT,
$in_buffer, 100, 0);
chomp($in_buffer);
print("$in_buffer\n");
}
close(UDP_CLIENT);
服务器端的代码:
BEGIN{
if( $^O
eq 'MSWin32' ){
require
Win32::Console;
Win32::Console::Free();
}
}
use strict;
use DBI;
#database parameters
my $db_path = 'd:/src/cc/phones.db';
my $dbh =
DBI->connect("dbi:SQLite:$db_path", {PrintError => 0}) or die
$DBI::errstr;
my $sth = undef;
#socket server parameters
my $in_buffer = undef;
my $out_buffer = undef;
my $PF_INET = 2;
my $port = 2345;
my $local_addr =
pack('SnC4x8',$PF_INET,$port,192,168,138,228);
my $SOCK_DGRAM = 2;
socket(UDP_SERVER, $PF_INET,$SOCK_DGRAM,
getprotobyname('udp')) or die("$!");
bind(UDP_SERVER, $local_addr) or die("$!");
listen(UDP_SERVER, 10);
while(1){
#receive
query then send result
last
unless my $remote_addr = recv(UDP_SERVER,$in_buffer,100,0);
chomp($in_buffer);
if($in_buffer
=~ /^[0-9]{6}$/){
$sth
= $dbh->prepare("select * from phones where number = $in_buffer");
PROCEDURE:
$sth->execute();
my
@items = $sth->fetchrow_array();
if(scalar(@items)){
$out_buffer
= $items[0].'
的虚拟网号码是
'.$items[1];
}else{
$out_buffer
= '
查无此人
';
}
}else{
$sth
= $dbh->prepare("select * from phones where name = '$in_buffer'");
goto
PROCEDURE;
}
send(UDP_SERVER,$out_buffer,0,$remote_addr);
}
#disconnect from sqlite
$dbh->disconnect();
前段时间看见ibm上有人介绍tiny c,就下了一个试试,感觉不错,为了方便起见,又弄了一个bat。
比方说,我把tiny c安装在d盘根目录下,然后我在d盘里建个tiny的文件存放如下内容的名为tiny的bat文件:
@echo off
tcc -run -I d:/tcc/include -L d:/tcc/lib %1
然后在环境变量path中加入d:\tiny,然后就可以运行c脚本了。
写个hello, world,取名为hello.c,存在随便哪里。然后到cmd里,cd到那个文件夹下,再“tiny hello.c”,接着cmd里就会显示“hello, world”鸟。
因为要在windows上使用expect的缘故,所以学习了tcl。还是用我在上一篇随笔中使用的例子来入门。
set seconds [clock seconds]
set timer [clock format $seconds -format %D]
regexp {([0-9]{2})/([0-9]{2})/([0-9]{2})} $timer match month day year
set rep_smp "20$year$month$day"
set rep_full "20$year-$month-$day"
set rpjf [open {shixian.rpjf} r]
set tmp [open {tmp.txt} w]
while {[expr ![eof $rpjf]]} {
gets $rpjf content
set content [regsub {([0-9]{4})-([0-9]{2})-([0-9]{2})} $content $rep_full]
set content [regsub {[0-9]{4}[0-9]{2}[0-9]{2}} $content $rep_smp]
puts $tmp "$content"
}
flush $tmp
close $rpjf
close $tmp
tcl语法用一句话概括的话就是:命令加参数。相比perl与python来说,tcl的语法相对简单一些,但是这并不代表就不如以上两者,各有各的特点而已。在tk和expect上tcl不仅仅是先驱而且也是做得最好的。
都是用来更新一个rm视频参数文件的。最早学asp的时候顺便用vbs写了一个,后来学perl就又写了一个,现在学python,凑活也写一个。基本上算是我的一个入门程序。用途就是用简单正则表达式找到时间段,再将它更新为当天日期,更新后的数据存在temp.txt中。perl最短,python比较干净。
vbs:
dim regOR
set regOR=new regexp
regOR.ignorecase=True
regOR.global=True
regOR.pattern="^([0-9]{1})$"
dim mytime
mytime=date
yy=year(mytime)
mm=month(mytime)
dd=day(mytime)
if regOR.test(mm) then
mm=regOR.replace(mm,"0$1")
end if
if regOR.test(dd) then
dd=regOR.replace(dd,"0$1")
end if
mytime=yy & "-" & mm & "-" & dd
dest=yy & mm & dd
pattern1="(.*[^0-9])([0-9]{4}\-[0-9]{2}\-[0-9]{2})([^0-9].*)"
pattern2="(.*[^0-9])([0-9]{8})([^0-9].*)"
regOR.pattern=pattern1
dim tempstring
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateTextFile("d:\shixian\temp.txt", True)
Set fr = fso.GetFile("d:\shixian\shixian.rpjf")
Set ts = fr.OpenAsTextStream(1,-2)
do until ts.AtEndOfStream
tempstring=ts.readline
if regOR.test(tempstring) then
tempstring=regOR.replace(tempstring,"$1" & mytime & "$3")
end if
regOR.pattern=pattern2
if regOR.test(tempstring) then
tempstring=regOR.replace(tempstring,"$1" & dest & "$3")
end if
regOR.pattern=pattern1
f.writeline(tempstring)
loop
ts.close
f.close
set regOR=nothing
set ts=nothing
set fr=nothing
set f=nothing
set fso=nothing
perl:
open(RPJF,"<c:/code/10161.rpjf") or die("can not open because of $!\n");
open(TEMP,">c:/code/temp.txt") or die("can not open because of $!\n");
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime();
$mday = sprintf("%.2d",$mday);
$mon = sprintf("%.2d",$mon+1);
$year += 1900;
$timerF = "$year"."$mon"."$mday";
$timerS = "$year"."-"."$mon"."-"."$mday";
while(<RPJF>){
chomp();
$_=~s/(.*)([0-9]{8})(.*)/$1$timerF$3/;
$_=~s/(.*)([0-9]{4}\-[0-9]{2}\-[0-9]{2})(.*)/$1$timerS$3/;
print TEMP "$_\n";
}
close(RPJF);
close(TEMP);
python:
import re
import time
pattern_name = re.compile(r'[0-9]{8}')
pattern_info = re.compile(r'[0-9]{4}\-[0-9]{2}\-[0-9]{2}')
(year, month, day) = time.localtime()[:3]
name = '%d%.2d%.2d' % (year, month, day)
info = '%d-%.2d-%.2d' % (year, month, day)
try:
file_rpjf = open('shixian.rpjf', 'r')
file_temp = open('temp.txt', 'w')
try:
file_data = file_rpjf.readline()
while file_data != '':
file_data = pattern_name.sub(name, file_data)
file_data = pattern_info.sub(info, file_data)
file_temp.write(file_data)
file_data = file_rpjf.readline()
finally:
file_rpjf.close()
file_temp.close()
except IOError:
pass
近年来python发展迅猛,无论在gui还是在web开发上渐渐显示出强大的实力。而perl却由于初期错误的开发方向,导致迟迟无法发布perl6。相比与python的蒸蒸日上、优秀的开发平台、活跃的社区,perl给人的感觉就是江河日下。单说wxwidget,perl版的连英文文档都少的可怜,而python早就有boa这样优秀的平台了;而在perl原先引以为傲的web开发领域,现在的perl又有多少发言权,所谓的成功案例永远都是亚马逊在线。难以驾驭大型项目更是perl的顽疾,越来越多的perler转向了python。虽然还是可以用缓慢而迟钝的pugs体验也许永远不会到来的perl6,但是还是会感到一些失落。
主要用于收集ip、mac、姓名、房间,后来又加入了维修记录的功能。服务器端接受数据并存入数据库中。
#############################
use strict;
use Tk;
use Encode;
#SOCKE参数
my $PF_INET = 2;
my $port = 2345;
my $remote_addr = pack('SnC4x8',$PF_INET,$port,192,168,138,228);
my $SOCK_DGRAM = 2;
#Frame
my ($label_room, $label_name, $label_ctrl, $label_notice);
#确定、取消
my ($enter, $cancel);
#房间、姓名变量
my ($room, $name);
$room = '';
$name = '';
#主界面
my $mw = MainWindow->new(-title => hanzi('信息收集'));
$mw->minsize(qw/200 100/);
$mw->maxsize(qw/200 100/);
#三个Frame
$label_room = $mw->Frame( qw/-borderwidth 2 -relief groove/ )->pack( qw/-side top -fill both/ );
$label_name = $mw->Frame( qw/-borderwidth 2 -relief groove/ )->pack( qw/-side top -fill both/ );
$label_ctrl = $mw->Frame( qw/-borderwidth 2 -relief groove/ )->pack( qw/-side top -fill both/ );
#房间号码输入
$label_room->Label(-text => hanzi('房间号码'))->pack(qw/-side left -expand 1/);
$label_room->Entry(-textvariable => \$room, -relief => 'groove')->pack(qw/-side right -expand 1/);
#姓名输入
$label_name->Label(-text => hanzi('姓名'))->pack(qw/-side left -expand 1/);
$label_name->Entry(-textvariable => \$name, -relief => 'groove')->pack(qw/-side right -expand 1/);
#确定与重置
$enter = $label_ctrl->Button(-text => hanzi('确定'), -command => \&enter)->pack(qw/-side left -expand 1/);
$cancel = $label_ctrl->Button(-text => hanzi('重置'), -command => \&cancel)->pack(qw/-side right -expand 1/);
#提示
$label_notice = $mw->Label(-text => hanzi('欢迎使用'), -relief => 'groove', -background => '#FFFF99')->pack(qw/-side bottom -fill x/);
MainLoop();
#汉字解码
sub hanzi{
return decode('gb2312', shift);
}
#确定函数
sub enter{
chomp($room);
chomp($name);
$room =~ s/^\s+//;
$name =~ s/^\s+//;
if($room eq '' or $name eq ''){
$label_notice->configure(-text => hanzi('输入不能为空')) ;
return 0;
}#if
else{
open(IPCF,'-|',"ipconfig -all");
my ($mac_addr, $ip_addr, $out_buffer);
while(<IPCF>){
chomp;
if($_ = ~s/(.*)(00(\-[0-9A-Z]{2}){5})(.*)/$2/){
$mac_addr = join('', split(/-/,$_));
}
if($_ = ~/IP Address/){
$_ = ~s/(.*)([0-9]{3}(\.[0-9]{1,3}){3})(.*)/$2/;
$ip_addr = $_;
}
}#while
$out_buffer = $room."\t".$mac_addr."\t".$ip_addr."\t".encode('utf8', $name);
socket(UDP_CLIENT, $PF_INET, $SOCK_DGRAM, getprotobyname('udp'));
send(UDP_CLIENT, $out_buffer, 0, $remote_addr);
close(UDP_CLIENT);
close(IPCF);
$mw->destroy();
}#else
}
#重置函数
sub cancel{
$label_notice->configure(-text => hanzi('重置为空'));
$room = '';
$name = '';
}
已
停止下载(近一千行代码,用perl写真累.....,不比ms的,纯粹玩票)大家看着玩玩儿吧~ ,单位在用了。:- ()
主要用到tk和dbi模块,因为喜欢用groove的效果(tk除了方便真没什么),所以比较土。有要学习tk,dbi的可以看看,蛮多代码都好重用的。
在
perl
中操作数据库中文字段
Perl
中对程序中的语句是按
utf8
的编码处理的,对英文没有什么影响,但是中文就有一些麻烦。
比方说,在
notepad
中默认是以
gb2312
的编码处理中文。如果在其中编写带有中文的
perl
程序,一般都难令人如意。这种情况下,一般会拜托
encode
模块,它是天然集成在
activeperl5.8.8
中的,如果没有找到可在
ppm
中
search
一下。
通常只要用到一下两个函数即可:
l
encode(‘
编码
’, ‘
文字
’)
l
decode(‘
编码
’,
数据
)
其中
decode
是将其中编码形式的文字转换为
utf8
数据;而
encode
则是将以
utf8
编码的数据转换为编码形式的文字。举一个例子:
$str = decode(‘gb2312’, ‘
你好
’);
Print encode(‘gb2312’, $str);
以上是可以正确打印出“你好”二字的。首先是告诉
perl
“你好”是一个
gb2312
编码的文字,
perl
把它以
utf8
的形式存在
$str
中;在将
$str
以
gb2312
的形式转换为文字并打印出来。
再说一下数据库。数据库都有自己的编码方式,比如说
utf8
、
eu_cn
、
gbk
等等。一定编码方式的数据库只能接受相应编码的数据,一般从兼容性上考虑会使用
utf8
编码的数据库。
在
postgres8.1
中,向一定编码的数据库中输入数据时,可以用
\encoding
将
client encode
设为与输入数据相同的形式。比方说在
psql
中向
utf8
编码的数据库插入
gbk
编码的汉字,就可以:
\encoding ‘gbk’
不然只会得到一个无法输入的提示。遗憾的是,
perl
里没有像
\encoding
这样的命令,于是又要拜托
encode
模块了。
#------------------------------------
use DBI;
use Encode;
use strict;
#连接数据库
my $dbh = DBI->connect("dbi:PgPP:dbname=
数据库名
:host=
服务器地址
:port=
服务器端口
",
登录名
,
登录密码
,{PrintError => 0})
or die $DBI::errstr;
#准备sql语句
my $inr = $dbh->prepare("insert into name values('encode('utf8', decode('gb2312','
你好
'))')")
or die $DBI::errstr;
#执行sql语句
$inr->execute() or die $DBI::errstr;
#打印成功信号
print "WELL DONE!";
#---------------------------------------