├── .gitignore ├── .gitmodules ├── Dockerfile ├── README.markdown ├── bin ├── avi2ts ├── csshX ├── diff-highlight ├── dzil-complete ├── git-check ├── git-intg ├── git-pa ├── git-paf ├── git-sync ├── git-tag-cleanup ├── git-wtf ├── meeko-db-update-schema ├── meeko-vlad-manifest-rebuild ├── mpr ├── mpz ├── orc-cpanfile ├── orc-project-root ├── perldoc-complete ├── pod2xhtml ├── prj ├── q ├── r ├── ssid2key.py ├── swaks.pl ├── tack ├── tt ├── x-apple-log-battery-status ├── x-apple-show-wireless-power ├── x-aws-docker-run ├── x-aws-exec ├── x-benchmark-perl-serialize ├── x-bork-bork-bork ├── x-compare-dirs ├── x-couchdb-benchmark ├── x-cpan-update ├── x-css-minifier ├── x-curl ├── x-datetime-converter ├── x-dbi-to-csv ├── x-dbi-to-excel ├── x-dns-xmpp-records ├── x-dns-zerigo-check ├── x-docker-remove-unused-images ├── x-dot-check ├── x-email-extract-html-part ├── x-evolui-timeline ├── x-excel-compare ├── x-filter-strip-trailing-whitespace ├── x-gen-crypt-pass ├── x-git-changelog ├── x-git-open-in-github ├── x-git-timeline ├── x-git-to-doc-website ├── x-git-update-to-latest-version ├── x-hipchat ├── x-html-escape ├── x-html-use-my-css ├── x-http-proxy-start-port-8469 ├── x-http-recorder ├── x-https-certificate-dump ├── x-import-db-codigo-postal-pt ├── x-itunes-decrypt-all ├── x-javascript-create-bookmarklet ├── x-js-minifier ├── x-json-parse ├── x-links-to-relative ├── x-logbook ├── x-mac-hosts-edit ├── x-mac-ramdisk ├── x-map-network-connections-mesh ├── x-markdown-preview ├── x-mime-exploder ├── x-music-what-who ├── x-mysql-check-tables ├── x-mysql-table-report ├── x-net-my-external-ip ├── x-net-my-ip-address ├── x-net-upnp-browser ├── x-notify ├── x-password-char-table ├── x-pdf-stack ├── x-perl-bench ├── x-perl-benchmark-xml-parsers ├── x-perl-c3-visualize ├── x-perl-check-config ├── x-perl-completions ├── x-perl-confess-env ├── x-perl-cover-env ├── x-perl-create-cpanfile-snapshot ├── x-perl-docker-this ├── x-perl-edit-installed-module ├── x-perl-expand-signature ├── x-perl-expand-signature-pp ├── x-perl-explain ├── x-perl-hilite ├── x-perl-method2sub2method ├── x-perl-module-info ├── x-perl-override ├── x-perl-scan-uses ├── x-perl-send-test-reports ├── x-perl-trace ├── x-perldoc-html ├── x-php2json ├── x-pod ├── x-pod-complete ├── x-pod-server ├── x-prove-since ├── x-prove-test-count ├── x-qmail-remove-bounce-from-queue ├── x-random ├── x-redis-sniffer ├── x-redis-start-server ├── x-setup-brew ├── x-setup-perl-modules ├── x-setup-work-jumper ├── x-show-unicode-chars ├── x-sphinx-charset-generator ├── x-sql-diff ├── x-ssh ├── x-ssl-check-server-cert ├── x-ssl-self-signed-cert ├── x-start-nsq ├── x-start-redis-server ├── x-stgit-update-to-latest-version ├── x-sync-music ├── x-terminal-clear ├── x-test-continuous ├── x-test-count ├── x-text-autoformat ├── x-text-recode ├── x-text-title-case-gruber ├── x-textile ├── x-textmate-update-support-directory ├── x-update-my-perl-environment ├── x-video-info ├── x-watch-fs ├── x-watch-load ├── x-xml-format-clipboard ├── x-xmpp-send ├── x-zeromq-pubsub-forwarder ├── x-zeromq-pubsub-subscriber └── youtube-dl ├── cpanfile └── etc └── tinyproxy.conf /.gitignore: -------------------------------------------------------------------------------- 1 | bin/local/ 2 | local/ 3 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "ext/zsh-bit-prompt"] 2 | path = ext/zsh-bit-prompt 3 | url = https://github.com/olivierverdier/zsh-git-prompt.git 4 | [submodule "elib/meeko"] 5 | path = elib/meeko 6 | url = git@git.worten.net:pocahontas/meeko.git 7 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM melopt/perl-alt:perl-latest-build AS build 2 | 3 | COPY cpanfile /app 4 | RUN cd /app && pdi-build-deps 5 | 6 | 7 | FROM melopt/perl-alt:perl-latest-devel 8 | 9 | ENV PATH=/tools/bin:/deps/bin:/deps/local/bin:/stack/bin:/stack/local/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin 10 | 11 | COPY --from=build /deps /deps 12 | COPY bin/ /tools/bin/ 13 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | Scripts 2 | ======= 3 | 4 | This is my collection of scripts that I have available on most servers 5 | I work on. 6 | 7 | Most are written by me but sometimes I include useful scripts I 8 | found online. 9 | 10 | 11 | 12 | About the command names 13 | ----------------------- 14 | 15 | My commands have very long names because most of them I only use from 16 | time to time and I forget their names. 17 | 18 | Instead I try to name them in a way that makes tab-completion find the 19 | tool I want easily. 20 | 21 | Therefore, the commands start with `x-`. 22 | 23 | 24 | 25 | Dangerous commands 26 | ------------------ 27 | 28 | Without any arguments, no command is dangerous. That is you can run any 29 | command without arguments "to see what it does". If the command is a 30 | filter, it just sits there, waiting for input. Otherwise a short usage 31 | is printed 32 | 33 | 34 | 35 | Author 36 | ------ 37 | 38 | Most commands are written by me, Pedro Melo . 39 | 40 | To check the author of a specific command check the script source, or 41 | the AUTHORS file. 42 | -------------------------------------------------------------------------------- /bin/avi2ts: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ffmpeg=/Users/melo/Applications/Air\ Video\ Server.app/Contents/Resources/ffmpeg 4 | 5 | "$ffmpeg" -i $1 -f mpegts -acodec libmp3lame -ar 48000 -ab 64k -s 320x240 -vcodec libx264 -b 800k -flags +loop -cmp +chroma -partitions +parti4x4+partp8x8+partb8x8 -subq 5 -trellis 1 -refs 1 -coder 0 -me_range 16 -keyint_min 25 -sc_threshold 40 -i_qfactor 0.71 -bt 200k -maxrate 800k -bufsize 800k -rc_eq 'blurCplx^(1-qComp)' -qcomp 0.6 -qmin 10 -qmax 51 -qdiff 4 -level 30 -aspect 320:240 -g 30 -async 2 $2 6 | 7 | # /Users/melo/Applications/Air\ Video\ Server.app/Contents/Resources/ffmpeg \ 8 | # -threads 4 -flags2 +fast -flags +loop -g 30 -keyint_min 1 \ 9 | # -bf 0 -b_strategy 0 -flags2 -wpred-dct8x8 -cmp +chroma \ 10 | # -deblockalpha 0 -deblockbeta 0 -refs 1 -coder 0 -me_range 16 \ 11 | # -subq 5 -partitions +parti4x4+parti8x8+partp8x8 -trellis 0 \ 12 | # -sc_threshold 40 -i_qfactor 0.71 -qcomp 0.6 -map 0.0:0.0 \ 13 | # -map 0.1:0.1 -ss 0.0 -vf "crop=624:352:0:0, scale=568:320, pad=576:320" \ 14 | # -aspect 624:352 -y -async 1 -crf 29 -qmin 29 \ 15 | # -r 23.976 -f mpegts -i $1 $2 16 | # 17 | # /Users/melo/Applications/Air Video Server.app/Contents/Resources/ffmpeg --conversion-id 564e52b0-3850-4682-9f84-4d5ef5af806c --port-number 46631 -threads 4 -flags2 +fast -flags +loop -g 30 -keyint_min 1 -bf 0 -b_strategy 0 -flags2 -wpred-dct8x8 -cmp +chroma -deblockalpha 0 -deblockbeta 0 -refs 1 -coder 0 -me_range 16 -subq 5 -partitions +parti4x4+parti8x8+partp8x8 -trellis 0 -sc_threshold 40 -i_qfactor 0.71 -qcomp 0.6 -map 0.0:0.0 -map 0.1:0.1 -ss 0.0 -i /Volumes/Spare/Video/covert_affairs-2x08.avi -vf crop=624:352:0:0, scale=568:320, pad=576:320 -aspect 624:352 -y -async 1 -f h264 -vcodec libx264 -crf 29 -qmin 29 -r 23.976 /Volumes/Spare/Video/57ff9352-445e-413e-8ea5-77cb5658f995.h264 -f adts -ar 48000 -f wav -ac 2 - 18 | -------------------------------------------------------------------------------- /bin/diff-highlight: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Highlight by reversing foreground and background. You could do 4 | # other things like bold or underline if you prefer. 5 | my $HIGHLIGHT = "\x1b[7m"; 6 | my $UNHIGHLIGHT = "\x1b[27m"; 7 | my $COLOR = qr/\x1b\[[0-9;]*m/; 8 | 9 | my @window; 10 | 11 | while (<>) { 12 | # We highlight only single-line changes, so we need 13 | # a 4-line window to make a decision on whether 14 | # to highlight. 15 | push @window, $_; 16 | next if @window < 4; 17 | if ($window[0] =~ /^$COLOR*(\@| )/ && 18 | $window[1] =~ /^$COLOR*-/ && 19 | $window[2] =~ /^$COLOR*\+/ && 20 | $window[3] !~ /^$COLOR*\+/) { 21 | print shift @window; 22 | show_pair(shift @window, shift @window); 23 | } 24 | else { 25 | print shift @window; 26 | } 27 | 28 | # Most of the time there is enough output to keep things streaming, 29 | # but for something like "git log -Sfoo", you can get one early 30 | # commit and then many seconds of nothing. We want to show 31 | # that one commit as soon as possible. 32 | # 33 | # Since we can receive arbitrary input, there's no optimal 34 | # place to flush. Flushing on a blank line is a heuristic that 35 | # happens to match git-log output. 36 | if (!length) { 37 | local $| = 1; 38 | } 39 | } 40 | 41 | # Special case a single-line hunk at the end of file. 42 | if (@window == 3 && 43 | $window[0] =~ /^$COLOR*(\@| )/ && 44 | $window[1] =~ /^$COLOR*-/ && 45 | $window[2] =~ /^$COLOR*\+/) { 46 | print shift @window; 47 | show_pair(shift @window, shift @window); 48 | } 49 | 50 | # And then flush any remaining lines. 51 | while (@window) { 52 | print shift @window; 53 | } 54 | 55 | exit 0; 56 | 57 | sub show_pair { 58 | my @a = split_line(shift); 59 | my @b = split_line(shift); 60 | 61 | # Find common prefix, taking care to skip any ansi 62 | # color codes. 63 | my $seen_plusminus; 64 | my ($pa, $pb) = (0, 0); 65 | while ($pa < @a && $pb < @b) { 66 | if ($a[$pa] =~ /$COLOR/) { 67 | $pa++; 68 | } 69 | elsif ($b[$pb] =~ /$COLOR/) { 70 | $pb++; 71 | } 72 | elsif ($a[$pa] eq $b[$pb]) { 73 | $pa++; 74 | $pb++; 75 | } 76 | elsif (!$seen_plusminus && $a[$pa] eq '-' && $b[$pb] eq '+') { 77 | $seen_plusminus = 1; 78 | $pa++; 79 | $pb++; 80 | } 81 | else { 82 | last; 83 | } 84 | } 85 | 86 | # Find common suffix, ignoring colors. 87 | my ($sa, $sb) = ($#a, $#b); 88 | while ($sa >= $pa && $sb >= $pb) { 89 | if ($a[$sa] =~ /$COLOR/) { 90 | $sa--; 91 | } 92 | elsif ($b[$sb] =~ /$COLOR/) { 93 | $sb--; 94 | } 95 | elsif ($a[$sa] eq $b[$sb]) { 96 | $sa--; 97 | $sb--; 98 | } 99 | else { 100 | last; 101 | } 102 | } 103 | 104 | print highlight(\@a, $pa, $sa); 105 | print highlight(\@b, $pb, $sb); 106 | } 107 | 108 | sub split_line { 109 | local $_ = shift; 110 | return map { /$COLOR/ ? $_ : (split //) } 111 | split /($COLOR*)/; 112 | } 113 | 114 | sub highlight { 115 | my ($line, $prefix, $suffix) = @_; 116 | 117 | return join('', 118 | @{$line}[0..($prefix-1)], 119 | $HIGHLIGHT, 120 | @{$line}[$prefix..$suffix], 121 | $UNHIGHLIGHT, 122 | @{$line}[($suffix+1)..$#$line] 123 | ); 124 | } 125 | -------------------------------------------------------------------------------- /bin/dzil-complete: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use File::Spec::Functions qw( rel2abs catdir splitpath no_upwards ); 4 | 5 | # There is only one tricky bit here: when there is only one completion, bash 6 | # will take that and append a space. But when completing to Foo:: we want bash 7 | # to leave the caret right after the :: and to make it do so, we make up a fake 8 | # 'Foo:: ' suggestion in `suggestion_from_name` to create artificial ambiguity. 9 | # However, if we also have a plain Foo suggestion anyway, then there is already 10 | # ambiguity and we can throw the fake suggestion away in `uniq`. 11 | 12 | sub uniq { my %seen; grep { ++$seen{$_.':: '}; not $seen{$_}++ } @_ } 13 | 14 | sub get_completion_word { 15 | my $comp = substr $ENV{'COMP_LINE'}, 0, $ENV{'COMP_POINT'}; 16 | $comp =~ s/.*\h//; 17 | return $comp; 18 | } 19 | 20 | sub slurp_dir { 21 | opendir my $dir, shift or return; 22 | no_upwards readdir $dir; 23 | } 24 | 25 | sub suggestion_from_name { 26 | my ( $file_rx, $path, $name ) = @_; 27 | return if not $name =~ /$file_rx/; 28 | return $name.'::', $name.':: ' if -d catdir $path, $name; 29 | return $1; 30 | } 31 | 32 | sub suggestions_from_path { 33 | my ( $file_rx, $path ) = @_; 34 | map { suggestion_from_name $file_rx, $path, $_ } slurp_dir $path; 35 | } 36 | 37 | die << "END_HELP" if not exists $ENV{'COMP_LINE'}; 38 | 39 | To use, issue the following command in bash: 40 | 41 | \tcomplete -C dzil-complete dzil 42 | 43 | You probably want to put that line in your .bashrc 44 | 45 | END_HELP 46 | 47 | my $pkg = get_completion_word(); 48 | 49 | if ( $ENV{COMP_LINE} =~ /dzil \s+ \S* $/x ) { 50 | # complete a command 51 | $pkg = 'Dist::Zilla::App::Command::'.$pkg; 52 | } 53 | elsif( $ENV{COMP_LINE} =~ /dzil \s+ plugins \s+ \S* $/x ) { 54 | # complete a plugin name 55 | $pkg = 'Dist::Zilla::Plugin::'.$pkg; 56 | } 57 | else { 58 | # no suggestions 59 | exit; 60 | } 61 | 62 | ( my $path = $pkg ) =~ s{::}{/}g; 63 | 64 | # if the path ended in a single colon, 65 | # then pretend there were two of them 66 | # and prepend a colon to all suggestions 67 | my $pfx = ( $path =~ s{:\z}{/} ) ? ':' : ''; 68 | 69 | my ( undef, $subpath, $word ) = splitpath $path; 70 | 71 | my $file_rx = qr/\A(${\quotemeta $word}\w*)(?:\.pm|\.pod)?\z/; 72 | 73 | my $home = $ENV{'HOME'}; 74 | 75 | print "$pfx$_\n" for 76 | uniq 77 | sort 78 | map { suggestions_from_path $file_rx, $_ } 79 | uniq 80 | map { catdir $_, $subpath } 81 | grep { $home ne rel2abs $_ } 82 | @INC; 83 | -------------------------------------------------------------------------------- /bin/git-check: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Cwd 'getcwd'; 6 | 7 | my @targets = @ARGV; 8 | @targets = ('.') unless @targets; 9 | 10 | my $pwd = getcwd(); 11 | for my $d (@targets) { 12 | chdir($pwd) or next; 13 | next unless -d $d; 14 | 15 | chdir($d) or next; 16 | next unless -d '.git'; 17 | 18 | my $m = `git status`; 19 | 20 | my ($branch) = $m =~ m/^# On branch ([^\n\r]+)/; 21 | $branch = '' unless $branch; 22 | 23 | my $status = $m =~ m/[(]working directory clean[)]/g ? 'clean' : 'dirty'; 24 | 25 | print "$status: $d on $branch\n"; 26 | } 27 | -------------------------------------------------------------------------------- /bin/git-intg: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Keeps a intg branch with all the f-* branches 4 | # 5 | 6 | ## Make sure we are in the root of the repo 7 | if [ ! -d .git ] ; then 8 | echo 9 | echo "FATAL: this is not the root of the repository" 10 | echo 11 | exit 1 12 | fi 13 | 14 | ## Make sure we are clean 15 | clean_marker="nothing to commit (working directory clean)" 16 | is_clean=`git status | grep "$clean_marker"` 17 | if [ "$is_clean" != "$clean_marker" ] ; then 18 | echo 19 | echo "FATAL: this repo has unfinished business. Run:" 20 | echo 21 | echo " git status" 22 | echo 23 | echo "to check whats up." 24 | echo 25 | exit 1 26 | fi 27 | 28 | intg_marker=.this_is_the_intg_branch 29 | 30 | ## Deal with --create 31 | if [ "$1" == "--create" ] ; then 32 | haz_intg=`git branch | cut -c3- | egrep "^intg$"` 33 | if [ ! -z "$haz_intg" ] ; then 34 | echo "FATAL: you already have a 'intg' branch" 35 | exit 1 36 | fi 37 | 38 | git checkout -b intg ${3:master} 39 | touch $intg_marker 40 | git add $intg_marker 41 | git ci -m 'Mark this branch as intg' $intg_marker 42 | echo "Done! You can start your integration now. Run:" 43 | echo 44 | echo " git intg" 45 | echo 46 | exit 0 47 | fi 48 | 49 | ## If a parameter is given, assume it is the desired intg branch 50 | if [ -n "$1" ] ; then 51 | git checkout $1 52 | fi 53 | 54 | ## Make sure this is a intg branch 55 | if [ ! -e $intg_marker ] ; then 56 | cat <>> Record intg merge to reset later" 83 | git show --pretty=format:%H --quiet > $intg_marker 84 | git commit -m 'intg marker updated with reset commit' $intg_marker 85 | 86 | ## Create the branch and be happy 87 | branch_to_merge=`git branch | cut -c3- | egrep ^f- | sort` 88 | echo "Creating 'intg' branch from: $branch_to_merge" 89 | git merge --no-ff $branch_to_merge 90 | 91 | 92 | ## Warn about conflits and stuff 93 | is_clean=`git status | grep "$clean_marker"` 94 | if [ "$is_clean" != "$clean_marker" ] ; then 95 | cat < 8 | 9 | 10 | for remote in `git remote` ; do 11 | echo "*** Updating $remote" 12 | echo "....... pushing all refs" 13 | git push --all $remote 14 | echo "....... pushing all tags" 15 | git push --tags $remote 16 | done 17 | -------------------------------------------------------------------------------- /bin/git-paf: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Do a git push to all our repositories 4 | # 5 | # Released to the public domain 6 | # 7 | # Pedro Melo, January 2011, 8 | 9 | 10 | for remote in `git remote` ; do 11 | printf "*** $remote: " 12 | git push -f $remote $@ 13 | done 14 | -------------------------------------------------------------------------------- /bin/git-sync: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Sync local repo to all remotes 4 | # 5 | 6 | repos=`git remote` 7 | 8 | for repo in $repos ; do 9 | echo "*** Pushing to '$repo'" 10 | printf " all branches... " 11 | git push --all $@ $repo 12 | printf " all tags....... " 13 | git push --tags $@ $repo 14 | done 15 | -------------------------------------------------------------------------------- /bin/git-tag-cleanup: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Remove duplicate tags for the same SHA1 4 | # 5 | 6 | use strict; 7 | use warnings; 8 | 9 | open(my $tag_list, '-|', 'git show-ref --tags | sort -r') 10 | || die "Failed to exec git show-ref: $!,"; 11 | 12 | my %dups; 13 | while (<$tag_list>) { 14 | my ($sha, $tag) = m{^([0-9a-f]+) refs/tags/(.+)}; 15 | next unless $sha && $tag; 16 | 17 | if (exists $dups{$sha}) { 18 | my $r = system('git', 'tag', '-d', $tag); 19 | print "Failed to exec() - git tag -d $tag: $!" if $r >> 8; 20 | } 21 | else { 22 | $dups{$sha} = $tag; 23 | } 24 | } 25 | 26 | close($tag_list); 27 | -------------------------------------------------------------------------------- /bin/git-wtf: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ruby 2 | 3 | HELP = < 54 | .git-wtfrc" and edit it. The config file is a YAML file that specifies the 55 | integration branches, any branches to ignore, and the max number of commits to 56 | display when --all-commits isn't used. git-wtf will look for a .git-wtfrc file 57 | starting in the current directory, and recursively up to the root. 58 | 59 | IMPORTANT NOTE: all local branches referenced in .git-wtfrc must be prefixed 60 | with heads/, e.g. "heads/master". Remote branches must be of the form 61 | remotes//. 62 | EOS 63 | 64 | COPYRIGHT = <. 66 | This program is free software: you can redistribute it and/or modify it 67 | under the terms of the GNU General Public License as published by the Free 68 | Software Foundation, either version 3 of the License, or (at your option) 69 | any later version. 70 | 71 | This program is distributed in the hope that it will be useful, but WITHOUT 72 | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or 73 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 74 | more details. 75 | 76 | You can find the GNU General Public License at: http://www.gnu.org/licenses/ 77 | EOS 78 | 79 | require 'yaml' 80 | CONFIG_FN = ".git-wtfrc" 81 | 82 | class Numeric; def pluralize s; "#{to_s} #{s}" + (self != 1 ? "s" : "") end end 83 | 84 | if ARGV.delete("--help") || ARGV.delete("-h") 85 | puts USAGE 86 | exit 87 | end 88 | 89 | ## poor man's trollop 90 | $long = ARGV.delete("--long") || ARGV.delete("-l") 91 | $short = ARGV.delete("--short") || ARGV.delete("-s") 92 | $all = ARGV.delete("--all") || ARGV.delete("-a") 93 | $all_commits = ARGV.delete("--all-commits") || ARGV.delete("-A") 94 | $dump_config = ARGV.delete("--dump-config") 95 | $key = ARGV.delete("--key") || ARGV.delete("-k") 96 | $show_relations = ARGV.delete("--relations") || ARGV.delete("-r") 97 | ARGV.each { |a| abort "Error: unknown argument #{a}." if a =~ /^--/ } 98 | 99 | ## search up the path for a file 100 | def find_file fn 101 | while true 102 | return fn if File.exist? fn 103 | fn2 = File.join("..", fn) 104 | return nil if File.expand_path(fn2) == File.expand_path(fn) 105 | fn = fn2 106 | end 107 | end 108 | 109 | want_color = `git config color.wtf` 110 | want_color = `git config color.ui` if want_color.empty? 111 | $color = case want_color.chomp 112 | when "true"; true 113 | when "auto"; $stdout.tty? 114 | end 115 | 116 | def red s; $color ? "\033[31m#{s}\033[0m" : s end 117 | def green s; $color ? "\033[32m#{s}\033[0m" : s end 118 | def yellow s; $color ? "\033[33m#{s}\033[0m" : s end 119 | def cyan s; $color ? "\033[36m#{s}\033[0m" : s end 120 | def grey s; $color ? "\033[1;30m#{s}\033[0m" : s end 121 | def purple s; $color ? "\033[35m#{s}\033[0m" : s end 122 | 123 | ## the set of commits in 'to' that aren't in 'from'. 124 | ## if empty, 'to' has been merged into 'from'. 125 | def commits_between from, to 126 | if $long 127 | `git log --pretty=format:"- %s [#{yellow "%h"}] (#{purple "%ae"}; %ar)" #{from}..#{to}` 128 | else 129 | `git log --pretty=format:"- %s [#{yellow "%h"}]" #{from}..#{to}` 130 | end.split(/[\r\n]+/) 131 | end 132 | 133 | def show_commits commits, prefix=" " 134 | if commits.empty? 135 | puts "#{prefix} none" 136 | else 137 | max = $all_commits ? commits.size : $config["max_commits"] 138 | max -= 1 if max == commits.size - 1 # never show "and 1 more" 139 | commits[0 ... max].each { |c| puts "#{prefix}#{c}" } 140 | puts grey("#{prefix}... and #{commits.size - max} more (use -A to see all).") if commits.size > max 141 | end 142 | end 143 | 144 | def ahead_behind_string ahead, behind 145 | [ahead.empty? ? nil : "#{ahead.size.pluralize 'commit'} ahead", 146 | behind.empty? ? nil : "#{behind.size.pluralize 'commit'} behind"]. 147 | compact.join("; ") 148 | end 149 | 150 | def widget merged_in, remote_only=false, local_only=false, local_only_merge=false 151 | left, right = case 152 | when remote_only; %w({ }) 153 | when local_only; %w{( )} 154 | else %w([ ]) 155 | end 156 | middle = case 157 | when merged_in && local_only_merge; green("~") 158 | when merged_in; green("x") 159 | else " " 160 | end 161 | print left, middle, right 162 | end 163 | 164 | def show b 165 | have_both = b[:local_branch] && b[:remote_branch] 166 | 167 | pushc, pullc, oosync = if have_both 168 | [x = commits_between(b[:remote_branch], b[:local_branch]), 169 | y = commits_between(b[:local_branch], b[:remote_branch]), 170 | !x.empty? && !y.empty?] 171 | end 172 | 173 | if b[:local_branch] 174 | puts "Local branch: " + green(b[:local_branch].sub(/^heads\//, "")) 175 | 176 | if have_both 177 | if pushc.empty? 178 | puts "#{widget true} in sync with remote" 179 | else 180 | action = oosync ? "push after rebase / merge" : "push" 181 | puts "#{widget false} NOT in sync with remote (you should #{action})" 182 | show_commits pushc unless $short 183 | end 184 | end 185 | end 186 | 187 | if b[:remote_branch] 188 | puts "Remote branch: #{cyan b[:remote_branch]} (#{b[:remote_url]})" 189 | 190 | if have_both 191 | if pullc.empty? 192 | puts "#{widget true} in sync with local" 193 | else 194 | action = pushc.empty? ? "merge" : "rebase / merge" 195 | puts "#{widget false} NOT in sync with local (you should #{action})" 196 | show_commits pullc unless $short 197 | end 198 | end 199 | end 200 | 201 | puts "\n#{red "WARNING"}: local and remote branches have diverged. A merge will occur unless you rebase." if oosync 202 | end 203 | 204 | def show_relations b, all_branches 205 | ibs, fbs = all_branches.partition { |name, br| $config["integration-branches"].include?(br[:local_branch]) || $config["integration-branches"].include?(br[:remote_branch]) } 206 | if $config["integration-branches"].include? b[:local_branch] 207 | puts "\nFeature branches:" unless fbs.empty? 208 | fbs.each do |name, br| 209 | next if $config["ignore"].member?(br[:local_branch]) || $config["ignore"].member?(br[:remote_branch]) 210 | next if br[:ignore] 211 | local_only = br[:remote_branch].nil? 212 | remote_only = br[:local_branch].nil? 213 | name = if local_only 214 | purple br[:name] 215 | elsif remote_only 216 | cyan br[:name] 217 | else 218 | green br[:name] 219 | end 220 | 221 | ## for remote_only branches, we'll compute wrt the remote branch head. otherwise, we'll 222 | ## use the local branch head. 223 | head = remote_only ? br[:remote_branch] : br[:local_branch] 224 | 225 | remote_ahead = b[:remote_branch] ? commits_between(b[:remote_branch], head) : [] 226 | local_ahead = b[:local_branch] ? commits_between(b[:local_branch], head) : [] 227 | 228 | if local_ahead.empty? && remote_ahead.empty? 229 | puts "#{widget true, remote_only, local_only} #{name} #{local_only ? "(local-only) " : ""}is merged in" 230 | elsif local_ahead.empty? 231 | puts "#{widget true, remote_only, local_only, true} #{name} merged in (only locally)" 232 | else 233 | behind = commits_between head, (br[:local_branch] || br[:remote_branch]) 234 | ahead = remote_only ? remote_ahead : local_ahead 235 | puts "#{widget false, remote_only, local_only} #{name} #{local_only ? "(local-only) " : ""}is NOT merged in (#{ahead_behind_string ahead, behind})" 236 | show_commits ahead unless $short 237 | end 238 | end 239 | else 240 | puts "\nIntegration branches:" unless ibs.empty? # unlikely 241 | ibs.sort_by { |v, br| v }.each do |v, br| 242 | next if $config["ignore"].member?(br[:local_branch]) || $config["ignore"].member?(br[:remote_branch]) 243 | next if br[:ignore] 244 | local_only = br[:remote_branch].nil? 245 | remote_only = br[:local_branch].nil? 246 | name = remote_only ? cyan(br[:name]) : green(br[:name]) 247 | 248 | ahead = commits_between v, (b[:local_branch] || b[:remote_branch]) 249 | if ahead.empty? 250 | puts "#{widget true, local_only} merged into #{name}" 251 | else 252 | #behind = commits_between b[:local_branch], v 253 | puts "#{widget false, local_only} NOT merged into #{name} (#{ahead.size.pluralize 'commit'} ahead)" 254 | show_commits ahead unless $short 255 | end 256 | end 257 | end 258 | end 259 | 260 | #### EXECUTION STARTS HERE #### 261 | 262 | ## find config file and load it 263 | $config = { "integration-branches" => %w(heads/master heads/next heads/edge), "ignore" => [], "max_commits" => 5 }.merge begin 264 | fn = find_file CONFIG_FN 265 | if fn && (h = YAML::load_file(fn)) # yaml turns empty files into false 266 | h["integration-branches"] ||= h["versions"] # support old nomenclature 267 | h 268 | else 269 | {} 270 | end 271 | end 272 | 273 | if $dump_config 274 | puts $config.to_yaml 275 | exit 276 | end 277 | 278 | ## first, index registered remotes 279 | remotes = `git config --get-regexp ^remote\.\*\.url`.split(/[\r\n]+/).inject({}) do |hash, l| 280 | l =~ /^remote\.(.+?)\.url (.+)$/ or next hash 281 | hash[$1] ||= $2 282 | hash 283 | end 284 | 285 | ## next, index followed branches 286 | branches = `git config --get-regexp ^branch\.`.split(/[\r\n]+/).inject({}) do |hash, l| 287 | case l 288 | when /branch\.(.*?)\.remote (.+)/ 289 | name, remote = $1, $2 290 | 291 | hash[name] ||= {} 292 | hash[name].merge! :remote => remote, :remote_url => remotes[remote] 293 | when /branch\.(.*?)\.merge ((refs\/)?heads\/)?(.+)/ 294 | name, remote_branch = $1, $4 295 | hash[name] ||= {} 296 | hash[name].merge! :remote_mergepoint => remote_branch 297 | end 298 | hash 299 | end 300 | 301 | ## finally, index all branches 302 | remote_branches = {} 303 | `git show-ref`.split(/[\r\n]+/).each do |l| 304 | sha1, ref = l.chomp.split " refs/" 305 | 306 | if ref =~ /^heads\/(.+)$/ # local branch 307 | name = $1 308 | next if name == "HEAD" 309 | branches[name] ||= {} 310 | branches[name].merge! :name => name, :local_branch => ref 311 | elsif ref =~ /^remotes\/(.+?)\/(.+)$/ # remote branch 312 | remote, name = $1, $2 313 | remote_branches["#{remote}/#{name}"] = true 314 | next if name == "HEAD" 315 | ignore = !($all || remote == "origin") 316 | 317 | branch = name 318 | if branches[name] && branches[name][:remote] == remote 319 | # nothing 320 | else 321 | name = "#{remote}/#{branch}" 322 | end 323 | 324 | branches[name] ||= {} 325 | branches[name].merge! :name => name, :remote => remote, :remote_branch => "#{remote}/#{branch}", :remote_url => remotes[remote], :ignore => ignore 326 | end 327 | end 328 | 329 | ## assemble remotes 330 | branches.each do |k, b| 331 | next unless b[:remote] && b[:remote_mergepoint] 332 | b[:remote_branch] = if b[:remote] == "." 333 | b[:remote_mergepoint] 334 | else 335 | t = "#{b[:remote]}/#{b[:remote_mergepoint]}" 336 | remote_branches[t] && t # only if it's still alive 337 | end 338 | end 339 | 340 | show_dirty = ARGV.empty? 341 | targets = if ARGV.empty? 342 | [`git symbolic-ref HEAD`.chomp.sub(/^refs\/heads\//, "")] 343 | else 344 | ARGV.map { |x| x.sub(/^heads\//, "") } 345 | end.map { |t| branches[t] or abort "Error: can't find branch #{t.inspect}." } 346 | 347 | targets.each do |t| 348 | show t 349 | show_relations t, branches if $show_relations || t[:remote_branch].nil? 350 | end 351 | 352 | modified = show_dirty && `git ls-files -m` != "" 353 | uncommitted = show_dirty && `git diff-index --cached HEAD` != "" 354 | 355 | if $key 356 | puts 357 | puts KEY 358 | end 359 | 360 | puts if modified || uncommitted 361 | puts "#{red "NOTE"}: working directory contains modified files." if modified 362 | puts "#{red "NOTE"}: staging area contains staged but uncommitted files." if uncommitted 363 | 364 | # the end! 365 | -------------------------------------------------------------------------------- /bin/meeko-db-update-schema: -------------------------------------------------------------------------------- 1 | ../elib/meeko/bin/meeko-db-update-schema -------------------------------------------------------------------------------- /bin/meeko-vlad-manifest-rebuild: -------------------------------------------------------------------------------- 1 | ../elib/meeko/bin/meeko-vlad-manifest-rebuild -------------------------------------------------------------------------------- /bin/mpr: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Try to run a perl script, install missing modules and retry if 4 | # it fails 5 | # 6 | # mpr stands for magical perl run. All software should be magical. 7 | # 8 | # Written by Pedro Melo , 2011/10/28 9 | # 10 | 11 | use strict; 12 | use warnings; 13 | use IPC::Open3 'open3'; 14 | 15 | my $install_cmd = 'cpanm'; ## miyagawa++ 16 | 17 | TRY: while (1) { 18 | debug('EXECing', @ARGV); 19 | my $pid = open3(\*IN, \*OUT, undef, @ARGV); 20 | die "Could not exec command @ARGV: $!, " unless $pid; 21 | close(IN); 22 | 23 | while () { 24 | print $_; 25 | if (m/locate (\S+)[.]pm in [@]INC/ or m/^(\S+) version \S+ required/) { 26 | (my $pm = $1) =~ s{/}{::}g; 27 | debug('GOT PM TO INSTALL', $pm); 28 | 29 | debug('KILL PROBLEM CHILD', $pid); 30 | kill 9, $pid; ## Just in case he is acting stupid... 31 | waitpid($pid, 0); 32 | 33 | if ($ENV{VERBOSE}) { 34 | print "\n\n***** Missing dependency detected: $pm\n"; 35 | print "***** Running '$install_cmd $pm' to solve it\n\n"; 36 | } 37 | 38 | debug('INSTALL', $pm, 'using', $install_cmd); 39 | system($install_cmd, $pm); 40 | 41 | print "\n\n***** Done '$install_cmd $pm'\n\n" if $ENV{VERBOSE}; 42 | redo TRY; 43 | } 44 | } 45 | debug('BE WELL'); 46 | exit(0); 47 | } 48 | 49 | sub debug { 50 | print "#####[$$] @_\n" if $ENV{DEBUG}; 51 | } 52 | -------------------------------------------------------------------------------- /bin/mpz: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # mpz: pipe over ZeroMQ using Message::Passing 4 | # 5 | # Use mpz --help for more information 6 | # 7 | # dependencies: cpanm -n Message::Passing::ZeroMQ 8 | # 9 | # Pedro Melo, 2012 10 | # License: Artistic License v2 11 | # 12 | 13 | use strict; 14 | use warnings; 15 | use Message::Passing::DSL; 16 | use Message::Passing::Output::ZeroMQ; 17 | use Getopt::Long; 18 | 19 | my $def_addr = 'tcp://127.0.0.1:12390'; 20 | my $input_mode = !-t \*STDIN; 21 | my ($bind, $connect, $sub, $pub, $usage); 22 | 23 | if ($input_mode) { $connect = $pub = 1 } 24 | else { $bind = $sub = 1 } 25 | 26 | GetOptions( 27 | "bind" => \$bind, 28 | "connect" => \$connect, 29 | "publisher" => \$pub, 30 | "subscriber" => \$sub, 31 | "help" => \$usage, 32 | "usage" => \$usage 33 | ) or usage(); 34 | usage() if $usage; 35 | 36 | my $addr = shift || $def_addr; 37 | 38 | my %opts = (socket_type => ($pub ? 'PUB' : 'SUB')); 39 | $opts{socket_bind} = $addr if $bind; 40 | $opts{connect} = $addr if $connect; 41 | 42 | my $chain; 43 | if ($input_mode) { 44 | my $zout = Message::Passing::Output::ZeroMQ->new(%opts, linger => 1); ## linger until everything is sent 45 | while (<>) { 46 | chomp; 47 | $zout->consume($_); 48 | } 49 | } 50 | else { 51 | run_message_server message_chain { 52 | error_log(class => 'STDERR'); 53 | output output => (class => 'STDOUT'); 54 | input input => (%opts, class => 'ZeroMQ', output_to => 'output'); 55 | }; 56 | } 57 | exit(0); 58 | 59 | sub usage { 60 | print <<"USAGE"; 61 | Usage: source | mpz - or - mpz [| optional_dest] 62 | 63 | A UNIX pipe over ZeroMQ+Message::Passing. The twisted bit is that you 64 | can have multiple sources all sending to the same destination, and 65 | each source can start/stop at any time. 66 | 67 | Options: 68 | --help or --usage will print this message 69 | 70 | --bind Bind the ZeroMQ socket to an address 71 | --connect Connect the ZeroMQ socket to an address 72 | 73 | Output mode defaults to --bind, while input defaults to -- 74 | connect. 75 | 76 | --publisher Use PUB socket type, default for output mode 77 | --subscriber Use SUB socket type, default for input mode 78 | 79 | is the address to bind/connect, defaults to $def_addr 80 | 81 | Examples: 82 | 83 | Simple stream of a tail -F: 84 | 85 | receiver: mpz tcp://server:port 86 | sender: tail -F logfile | mpz tcp://server:port 87 | 88 | Add an heartbeat: 89 | 90 | receiver: mpz tcp://server:port 91 | sender 1: while true ; do date ; sleep 1 ; done | mpz tcp://server:port 92 | sender 2: tail -F logfile | mpz tcp://server:port 93 | 94 | Add an heartbeat+multiple tail -F's: 95 | 96 | receiver: mpz tcp://server:port 97 | sender 1: while true ; do date ; sleep 1 ; done | mpz tcp://server:port 98 | sender 2: tail -F logfile1 | mpz tcp://server:port 99 | sender 3: tail -F logfile2 | mpz tcp://server:port 100 | 101 | 102 | USAGE 103 | exit(2); 104 | } 105 | -------------------------------------------------------------------------------- /bin/orc-cpanfile: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use FindBin; 5 | use Path::Tiny; 6 | use Getopt::Long; 7 | use Module::CPANfile; 8 | use CPAN::Meta::Prereqs; 9 | 10 | ### What does this thing do?? 11 | 12 | sub usage { 13 | print STDERR "ERROR: @_\n" if @_; 14 | 15 | print STDERR < [options] 17 | 18 | Tools to manipulate project CPANfiles 19 | 20 | For now three 's are available: 21 | 22 | * list: lists all cpanfile's, recursively 23 | * merge: generates to stdout a single cpanfile - very primitive algorithm for now 24 | * install: install all deps, in a local directory (defaults to ./local) 25 | 26 | EOU 27 | 28 | exit(1); 29 | } 30 | 31 | 32 | ### Command line parsing 33 | 34 | my ($root_opt, $help_opt); 35 | 36 | GetOptions('root=s' => \$root_opt, 'help|?' => \$help_opt) or usage(); 37 | usage() if $help_opt; 38 | 39 | my $cmd = shift @ARGV; 40 | usage('a command is required') unless length($cmd); 41 | 42 | command_dispatch($cmd); 43 | exit(0); 44 | 45 | 46 | ### Command dispatch 47 | 48 | sub run (&;$) { 49 | my $p = $_[1] || `$FindBin::Bin/orc-project-root`; 50 | return $_[0]->(path($p)) if $p; 51 | exit(1); 52 | } 53 | 54 | sub command_dispatch { 55 | my ($cmd) = @_; 56 | 57 | if ($cmd eq 'list') { 58 | run { print "$_\n" for _find_cpanfiles($_[0]) } $root_opt; 59 | } 60 | elsif ($cmd eq 'merge') { 61 | run { print _merge_cpanfile($_[0]) } $root_opt; 62 | } 63 | elsif ($cmd eq 'install') { 64 | run { 65 | my $tmp = Path::Tiny->tempfile; 66 | $tmp->spew(_merge_cpanfile($_[0])); 67 | 68 | delete $ENV{LANG}; 69 | exec('cpanm', '--quiet', '--notest', @ARGV, '--cpanfile', $tmp->stringify, '--installdeps', '.'); 70 | } 71 | $root_opt; 72 | } 73 | else { 74 | usage("invalid command '$cmd'"); 75 | } 76 | } 77 | 78 | 79 | #### Utils 80 | 81 | sub _find_cpanfiles { 82 | my ($root) = @_; 83 | my $i = $root->iterator({ recurse => 1 }); 84 | my $self = path($FindBin::Bin)->child($FindBin::Script)->realpath; 85 | 86 | my @found; 87 | while (my $f = $i->()) { 88 | next unless $f->basename =~ m/.*cpanfile$/; ## no point going on if we don't have cpanfile on our name... 89 | 90 | my $r = $f->relative($root); 91 | next if $r eq 'cpanfile'; ## skip root cpanfile, we'll update that 92 | next if $r =~ m{^local/}; ## skip Carton install dir 93 | next if $r =~ m{^.docker-perl-local/}; ## skip Carton install dir via melopt/perl-alt setup 94 | next if $r =~ m{^.git/}; ## skip git dir also 95 | next if $f eq $self; ## We have cpanfile on our name too ;) 96 | 97 | print STDERR "... using $r\n" if $ENV{DEBUG}; 98 | push @found, $f; 99 | } 100 | 101 | return wantarray ? @found : \@found; 102 | } 103 | 104 | sub _merge_cpanfile { 105 | my ($root) = @_; 106 | 107 | # FIXME: the files we found might not be valid cpanfiles... how to test for that? 108 | # first attempt, restrict the name of the files 109 | my @cpanfiles = grep { $_->basename eq 'cpanfile' or $_->basename =~ m/\Q.cpanfile\E$/ } _find_cpanfiles($root); 110 | my @prereqs = map { Module::CPANfile->load($_)->prereqs } @cpanfiles; 111 | my $reqs = CPAN::Meta::Prereqs->new->with_merged_prereqs(\@prereqs); 112 | 113 | my $header = join("\n", 114 | '### *** DO NOT EDIT *** GENERATED AUTOMATICALY BY orc-cpanfile ***', 115 | '###', 116 | '### Merge of the following cpanfiles', 117 | map {"### * $_"} map { $_->relative($root) } @cpanfiles, 118 | ); 119 | 120 | return "$header\n\n" . Module::CPANfile->from_prereqs($reqs->as_string_hash)->to_string; 121 | } 122 | -------------------------------------------------------------------------------- /bin/orc-project-root: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | 4 | use strict; 5 | use Getopt::Long; 6 | use Path::Tiny; 7 | 8 | sub usage { 9 | print STDERR < \$help_opt) or usage(); 25 | usage() if $help_opt; 26 | 27 | my $p = path('.')->realpath; 28 | my $s = $ENV{HOME} ? path($ENV{HOME})->realpath : Path::Tiny->rootdir; 29 | while (!$p->is_rootdir and "$p" ne "$s") { 30 | if ($p->child('.pbs_project')->exists) { 31 | print $p->stringify; 32 | print "\n" if -t \*STDOUT; 33 | exit(0); 34 | } 35 | 36 | $p = $p->parent; 37 | } 38 | 39 | die "could not determine project root\n"; 40 | -------------------------------------------------------------------------------- /bin/perldoc-complete: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use File::Spec::Functions qw( rel2abs catdir catfile no_upwards ); 4 | 5 | sub uniq { my %seen; grep { not $seen{$_}++ } @_ } 6 | 7 | sub get_command_line { 8 | my $comp = substr $ENV{'COMP_LINE'}, 0, $ENV{'COMP_POINT'}; 9 | return split /[ \t]+/, $comp, -1; # if not good enough, use Text::ParseWords 10 | } 11 | 12 | sub slurp_dir { 13 | opendir my $dir, shift or return; 14 | no_upwards readdir $dir; 15 | } 16 | 17 | sub suggestion_from_name { 18 | my ( $file_rx, $path, $name ) = @_; 19 | return if not $name =~ /$file_rx/; 20 | return $name.'::' if -d catdir $path, $name; 21 | return $1; 22 | } 23 | 24 | sub suggestions_from_path { 25 | my ( $file_rx, $path ) = @_; 26 | map { suggestion_from_name $file_rx, $path, $_ } slurp_dir $path; 27 | } 28 | 29 | sub get_package_suggestions { 30 | my ( $pkg ) = @_; 31 | 32 | my @segment = split /::|:\z/, $pkg, -1; 33 | my $file_rx = qr/\A(${\quotemeta pop @segment}\w*)(?:\.pm|\.pod)?\z/; 34 | 35 | my $home = rel2abs $ENV{'HOME'}; 36 | my $cwd = rel2abs do { require Cwd; Cwd::cwd() }; 37 | 38 | my @suggestion = 39 | map { suggestions_from_path $file_rx, $_ } 40 | uniq map { catdir $_, @segment } 41 | grep { $home ne $_ and $cwd ne $_ } 42 | map { $_, ( catdir $_, 'pod' ) } 43 | map { rel2abs $_ } 44 | @INC; 45 | 46 | # fixups 47 | if ( $pkg eq '' ) { 48 | my $total = @suggestion; 49 | @suggestion = grep { not /^perl/ } @suggestion; 50 | my $num_hidden = $total - @suggestion; 51 | push @suggestion, "perl* ($num_hidden hidden)" if $num_hidden; 52 | } 53 | elsif ( $pkg =~ /(? ) { 75 | next if 1 .. /^=head2 Alphabetical Listing of Perl Functions$/; 76 | ++$nest_level if /^=over/; 77 | --$nest_level if /^=back/; 78 | next if $nest_level; 79 | push @suggestion, /^=item (-?\w+)/; 80 | } 81 | 82 | my $func_rx = qr/\A${\quotemeta $func}/; 83 | 84 | return grep { /$func_rx/ } @suggestion; 85 | } 86 | 87 | sub usage { 88 | die map "\n$_\n", ( 89 | "To use, issue the following command in bash:", 90 | "\tcomplete -C perldoc-complete -o nospace -o default perldoc", 91 | "You probably want to put that line in your ~/.bashrc file.\n", 92 | ); 93 | } 94 | 95 | usage() if not exists $ENV{'COMP_LINE'}; 96 | 97 | my ( $cmd, @arg ) = get_command_line(); 98 | my $word = pop @arg; 99 | 100 | print "$_\n" for ( @arg and @arg[-1] eq '-f' ) 101 | ? get_function_suggestions( $word ) 102 | : get_package_suggestions( $word ); 103 | -------------------------------------------------------------------------------- /bin/pod2xhtml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use 5.014; 4 | use warnings; 5 | use Pod::Simple::XHTML; 6 | use autodie; 7 | 8 | my ($module) = @ARGV; 9 | die <new; 29 | $psx->output_string(\my $html); 30 | $psx->parse_file($path); 31 | 32 | ### On tty, assume interactive and try and open a browser on it 33 | my $has_browser_open = eval { require Browser::Open }; 34 | #say "has $has_browser_open ", (-t \*STDOUT); 35 | unless ($has_browser_open && -t \*STDOUT) { 36 | say $html; 37 | exit(0); 38 | } 39 | 40 | ## Cache files (TODO: take in account mtime) 41 | my $cache = "$ENV{HOME}/.pod2xhtml"; 42 | require File::Path; 43 | File::Path::mkpath($cache); 44 | 45 | my $cache_filename = $module =~ s{::}{-}gr; 46 | $cache_filename = "$cache/$cache_filename.html"; 47 | 48 | open(my $out, '>', $cache_filename); 49 | say $out $html; 50 | 51 | Browser::Open::open_browser("file://$cache_filename"); 52 | -------------------------------------------------------------------------------- /bin/q: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | 5 | exec("rsync -a $ENV{HOME}/.ssh/*.pem $ENV{HOME}/.ssh/*.pub $ENV{HOME}/.ssh/config q:.ssh/") if $0 eq 'qs' or $ARGV[0] eq 'sync' or $ARGV[0] eq 's'; 6 | exec('ssh', 'q', @ARGV); 7 | -------------------------------------------------------------------------------- /bin/r: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use File::Spec::Functions qw( splitpath splitdir catpath catdir catfile rootdir ); 5 | use Cwd; 6 | 7 | die "Usage: r \n\n Find all lib's to add to PERL5LIB\n" unless @ARGV; 8 | 9 | my $mark_file = '.pbs_project'; 10 | my ($vol, $cur_dir) = splitpath(getcwd(), 1); 11 | $cur_dir = [splitdir($cur_dir)]; 12 | 13 | while (1) { 14 | my $dir = catpath($vol, catdir(@$cur_dir)); 15 | 16 | _exec_cmd($dir) if -e catfile($dir, $mark_file) and -f _; 17 | 18 | last if $ENV{HOME} and $dir eq $ENV{HOME}; 19 | last if $dir eq rootdir(); 20 | 21 | pop @$cur_dir; 22 | } 23 | 24 | die "Failed to find '$mark_file' file\n"; 25 | 26 | 27 | ### Exec command 28 | 29 | sub _exec_cmd { 30 | my ($dir) = @_; 31 | 32 | chdir($dir); 33 | if (-f 'cpanfile.snapshot' and -d 'local' and !$ENV{R_CARTON_EXEC_DONE}) { 34 | $ENV{R_CARTON_EXEC_DONE} = 1; ## use Carton exec once only! 35 | unshift @ARGV, qw(carton exec), $0; 36 | warn "Using Carton!\n" if $ENV{R_DEBUG}; 37 | } 38 | else { 39 | warn "Seting up PERL5LIB for '$dir'\n" if $ENV{R_DEBUG}; 40 | $ENV{PERL5LIB} = join(':', _find_libs($dir), split(/:/, $ENV{PERL5LIB} || '')); 41 | warn "Set to PERL5LIB: $ENV{PERL5LIB}\n" if $ENV{R_DEBUG}; 42 | } 43 | 44 | warn "Exec'ing: @ARGV\n" if $ENV{R_DEBUG}; 45 | warn "... with PERL5LIB: $ENV{PERL5LIB}\n" if $ENV{R_DEBUG}; 46 | exec(@ARGV); 47 | die "Failed to exec '@ARGV': $!"; 48 | } 49 | 50 | 51 | ### Find all lib deps 52 | 53 | sub _find_libs { 54 | my @dirs = @_; 55 | 56 | my @found; 57 | while (my $dir = shift @dirs) { 58 | my $l = catdir($dir, 'lib'); 59 | warn "Check '$dir' for 'lib/'\n" if $ENV{R_DEBUG}; 60 | push @found, $l if -d $l; 61 | 62 | my $elibs = catdir($dir, 'elib'); 63 | next unless opendir(my $dh, $elibs); 64 | push @dirs, grep { -d $_ } map { catfile($elibs, $_) } grep {m/^[^\.]/} readdir($dh); 65 | } 66 | 67 | return @found; 68 | } 69 | -------------------------------------------------------------------------------- /bin/ssid2key.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | # 3 | # Python version of stkeys.c by Kevin Devine (see http://weiss.u40.hosting.digiweb.ie/stech/) 4 | # Requires Python 2.5 for hashlib 5 | # 6 | # This script will generate possible WEP/WPA keys for Thomson SpeedTouch / BT Home Hub routers, 7 | # given the last 4 or 6 characters of the default SSID. E.g. For SSID 'SpeedTouchF8A3D0' run: 8 | # 9 | # ./ssid2key.py f8a3d0 10 | # 11 | # By Hubert Seiwert, hubert.seiwert@nccgroup.com 2008-04-17 12 | # 13 | # By default, keys for router serial numbers matching years 2005 to 2007 will be generated. 14 | # If you wish to change this, edit year_list below. 15 | 16 | import sys 17 | import hashlib 18 | 19 | ssid_end = sys.argv[1].lower() 20 | offset = 40-(len(ssid_end)) 21 | charset = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ' 22 | year_list = [2007,2008] 23 | 24 | def ascii2hex(char): 25 | return hex(ord(char))[2:] 26 | 27 | print 'Possible keys for SSID ending %s:' % ssid_end.upper() 28 | count = 0 29 | 30 | for year in [y-2000 for y in year_list]: 31 | for week in range(1,53): #1..52 32 | #print 'Trying year 200%d week %d' % (year,week) 33 | for char1 in charset: 34 | for char2 in charset: 35 | for char3 in charset: 36 | sn = 'CP%02d%02d%s%s%s' % (year,week,ascii2hex(char1),ascii2hex(char2),ascii2hex(char3)) 37 | hash = hashlib.sha1(sn.upper()).hexdigest() 38 | if hash[offset:] == ssid_end: 39 | print hash[0:10].upper() 40 | count += 1; 41 | print 'Done. %d possible keys found.' % count 42 | 43 | -------------------------------------------------------------------------------- /bin/tack: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # tack: run ack, parse output, convert to HTML, link lines back to TextMate 4 | # 5 | # Original version by Andy Armstrong (https://metacpan.org/author/ANDYA) 6 | # available here: http://api.metacpan.org/source/ANDYA/TextMate-JumpTo-0.07/examples/tack 7 | # 8 | # Pedro Melo (https://metacpan.org/author/MELO) adapted to changes 9 | # of ack output 10 | # 11 | 12 | use strict; 13 | use 5.014; 14 | use TextMate::JumpTo qw( tm_location ); 15 | use HTML::Tiny; 16 | use File::Temp qw( tempfile ); 17 | use Data::Dump 'pp'; 18 | 19 | $| = 1; 20 | 21 | my ($t, @args) = _args(); 22 | my ($w, $h) = _html_output(); 23 | 24 | $w->( 25 | $h->open('html'), 26 | $h->head( 27 | $h->meta( 28 | {'http-equiv' => 'Content-Type', content => 'text/html; charset=utf-8'} 29 | ), 30 | $h->title("Search results for $t"), 31 | $h->style( 32 | do { local $/; } 33 | ), 34 | $h->script( 35 | { src => 36 | 'https://ajax.googleapis.com/ajax/libs/jquery/1.6.4/jquery.min.js' 37 | } 38 | ), 39 | ), 40 | $h->open('body'), 41 | ); 42 | 43 | open my $ack, '-|', 'ack', @args or die "Can't run ack ($!)"; 44 | 45 | my $state = 'file'; 46 | my $cfile; 47 | 48 | LINE: 49 | while (defined(my $line = <$ack>)) { 50 | chomp $line; 51 | 52 | given ($state) { 53 | when ('file') { 54 | next if /^\s*$/; 55 | $w->( 56 | $h->h1($h->a({href => tm_location(file => $line, line => 1)}, $line)) 57 | ); 58 | $w->($h->open('div')); 59 | 60 | $state = 'in_block'; 61 | $cfile = $line; 62 | next LINE; 63 | } 64 | when ('in_block') { 65 | if (my ($ln, $f, $info) = $line =~ m/^(\d+)([:-])(.*)$/) { 66 | my $matched = $f eq ':'; 67 | my $url = tm_location(file => $cfile, line => $ln); 68 | $info =~ s/\t/ /g; 69 | $info =~ s/&/</g; 70 | $info =~ s//>/g; 72 | 73 | $w->( 74 | $h->p( 75 | {class => ($matched && 'matched')}, 76 | [ $h->a( 77 | {href => $url}, 78 | [ $h->span({class => 'ln'}, $ln), 79 | $h->span({class => 'code'}, $info) 80 | ] 81 | ), 82 | ] 83 | ) 84 | ); 85 | } 86 | elsif (my ($sep) = $line =~ m/^(--)?\s*$/) { 87 | $w->($h->close('div')); 88 | $w->($h->open('div')) if $sep; 89 | $state = 'file' unless $sep; 90 | } 91 | } 92 | } 93 | } 94 | close $ack; 95 | 96 | my $hover_js = <<'EOS'; 97 | $(function () { 98 | $('.matched').hover(function () { $(this).toggleClass('hover'); }); 99 | }); 100 | EOS 101 | 102 | $w->( 103 | $h->close('div'), $h->script([$hover_js]), 104 | $h->close('body'), $h->close('html'), 105 | ); 106 | _open($w->(), 0); 107 | 108 | sub _open { 109 | my ($url, $bg) = @_; 110 | my @cmd = ('/usr/bin/open', ($bg ? ('-g') : ()), $url); 111 | system @cmd and die "Can't open $url ($?)"; 112 | } 113 | 114 | sub _args { 115 | my @args = 116 | grep { $_ ne '--color' && $_ ne '--noheading' && $_ ne '--nobreak' } 117 | @ARGV; 118 | 119 | my $title = join(' ', @args); 120 | 121 | unshift @args, '--nocolor' unless grep { $_ eq '--nocolor' } @args; 122 | unshift @args, '--heading' unless grep { $_ eq '--heading' } @args; 123 | unshift @args, '--break' unless grep { $_ eq '--break' } @args; 124 | unshift @args, '--context=3' 125 | unless grep { $_ =~ /^(--context=\d+)|(-C)$/ } @args; 126 | 127 | return ($title, @args); 128 | } 129 | 130 | sub _html_output { 131 | my $h = HTML::Tiny->new; 132 | my ($fh, $filename) = tempfile(SUFFIX => '.html'); 133 | 134 | my $w = sub { 135 | return $fh->print(@_) if @_; 136 | 137 | close($fh); 138 | return $filename; 139 | }; 140 | 141 | return ($w, $h); 142 | } 143 | 144 | __DATA__ 145 | 146 | html, body { 147 | font-family: monospace; 148 | background: black; 149 | } 150 | 151 | a { 152 | text-decoration: none; 153 | width: 100%; 154 | } 155 | 156 | h1 { 157 | text-align: left; 158 | border-bottom: 1px solid #222; 159 | color: #ccc; 160 | padding-top: 10px; 161 | padding-bottom: 3px; 162 | margin-bottom: 3px; 163 | } 164 | 165 | p { 166 | color: #eee; 167 | margin: 0px; 168 | padding-left: 0 10px 0 10px; 169 | } 170 | 171 | .matched { 172 | background: #111; 173 | color: #fff; 174 | } 175 | 176 | 177 | .ln { 178 | color: #444; 179 | width: 5em; 180 | text-align: right; 181 | padding-right: 1em; 182 | } 183 | 184 | .code { 185 | color: #eee; 186 | } 187 | 188 | .matched .code { 189 | color: #fff; 190 | } 191 | 192 | p.hover { 193 | background: #555; 194 | } 195 | -------------------------------------------------------------------------------- /bin/tt: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | if [ -n "$1" -a "$1" = "build" ] ; then 6 | cd ~/.scripts.d 7 | docker build -t tools . 8 | exit 0 9 | fi 10 | 11 | exec docker run -it --rm -v `pwd`:/app tools 12 | -------------------------------------------------------------------------------- /bin/x-apple-log-battery-status: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | open(my $ioreg, '-|', 'ioreg -l'); 7 | 8 | my $found = 0; 9 | my %info; 10 | 11 | while (<$ioreg>) { 12 | chomp; 13 | if (!$found) { 14 | $found++ if /AppleSmartBattery >', $logfile) 36 | || die("Could not open log file '$logfile': $!\n"); 37 | 38 | my $now = time; 39 | print $log "t:$now # ".localtime($now)."\n"; 40 | 41 | my @keys = qw( 42 | FullyCharged IsCharging ExternalConnected 43 | CycleCount 44 | TimeRemaining 45 | MaxCapacity Voltage CurrentCapacity DesignCapacity 46 | Temperature 47 | ); 48 | 49 | foreach my $key (@keys) { 50 | my $new_key = $key; 51 | $new_key =~ s/([a-z])([A-Z])/${1}_${2}/g; 52 | $new_key = lc($new_key); 53 | 54 | my $value = $info{$key}; 55 | next unless defined $value; 56 | 57 | print $log "$new_key: $value\n"; 58 | } 59 | 60 | print $log "\n"; 61 | 62 | close($log); 63 | 64 | -------------------------------------------------------------------------------- /bin/x-apple-show-wireless-power: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # See 4 | # 5 | # 6 | # for more information 7 | 8 | while x=1; do 9 | /System/Library/PrivateFrameworks/Apple80211.framework/Versions/Current/Resources/airport -I | grep CtlRSSI 10 | sleep 0.5 11 | done 12 | 13 | -------------------------------------------------------------------------------- /bin/x-aws-docker-run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ -z "$*" ] ; then 4 | cat <] [] 6 | 7 | Executes a docker run passing along all "AWS_*" environment variables for a 8 | particular profile, using aws-vault for the credential handling. 9 | 10 | Equivalent to: 11 | 12 | exec docker run -it --rm -e AWS* 13 | 14 | EOU 15 | exit 2 16 | fi 17 | 18 | exec docker run -it --rm $( set | grep AWS_ | cut -f1 -d= | xargs -n1 echo '-e' ) "$@" 19 | -------------------------------------------------------------------------------- /bin/x-aws-exec: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | profile="$1" 4 | shift 5 | 6 | if [ -z "$profile" ] ; then 7 | cat < [] 9 | 10 | Executes under AWS credentials for , using aws-vault 11 | 12 | The defaults to $SHELL --login 13 | 14 | Equivalent to: 15 | 16 | aws-vault exec -- 17 | 18 | EOU 19 | exit 2 20 | fi 21 | 22 | cmd="aws-vault exec --assume-role-ttl=1h --session-ttl=1h $profile -- " 23 | 24 | if [ -z "$*" ] ; then 25 | exec $cmd $SHELL --login 26 | else 27 | exec $cmd "$@" 28 | fi 29 | -------------------------------------------------------------------------------- /bin/x-bork-bork-bork: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Filters text into bork-bork-bork 4 | # 5 | # You send in some text like this little explanation and you'll 6 | # get this: 7 | # 8 | # Yuoo send een sumea text leekea thees leettlea ixplunashun und yuoo'll 9 | # get thees 10 | # 11 | # Pedro Melo 12 | 13 | use strict; 14 | use warnings; 15 | use Getopt::Long; 16 | 17 | my $help; 18 | my $ok = GetOptions("help|?" => \$help); 19 | 20 | usage() if !$ok || $help; 21 | 22 | require_module('Lingua::Bork', qw(bork)); 23 | 24 | print bork($_) while (<>); 25 | 26 | ################################# 27 | # My little require module method 28 | 29 | sub require_module { 30 | my $module = shift; 31 | 32 | eval "require $module"; 33 | if (my $e = $@) { 34 | print STDERR "FATAL: $0 requires the Perl module '$module'.\n\n"; 35 | print STDERR "You can install it with:\n\n"; 36 | print STDERR " cpan $module\n\n"; 37 | exit(1); 38 | } 39 | $module->import(@_); 40 | } 41 | 42 | sub usage { 43 | print STDERR <recurse(depthfirst => 1, preorder => 0, callback => sub { 11 | my ($item) = @_; 12 | 13 | ## Try to remove directory, might be empty 14 | if ($item->is_dir) { 15 | print "rmdir $item\n"; 16 | return; 17 | } 18 | 19 | ## Equiv file on common not found => keep ours 20 | my $dest = $common->file($item->relative($work)); 21 | unless (-e $dest) { 22 | print "cp $item $common/$item\n"; 23 | return; 24 | } 25 | 26 | ## Digest both files 27 | my $src_h = Digest::SHA1->new; 28 | $src_h->addfile($item->openr); 29 | my $dst_h = Digest::SHA1->new; 30 | $dst_h->addfile($dest->openr); 31 | 32 | ## Remove source file if we have a match 33 | if ($dst_h->digest eq $src_h->digest) { 34 | print "rm $item\n" ; 35 | } 36 | else { 37 | print "open $item $common/$item\n"; 38 | print "echo different $item\n" ; 39 | } 40 | }); 41 | -------------------------------------------------------------------------------- /bin/x-couchdb-benchmark: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use AnyEvent; 6 | use AnyEvent::HTTP; 7 | use Time::HiRes qw( gettimeofday tv_interval ); 8 | 9 | $AnyEvent::HTTP::MAX_PERSISTENT_PER_HOST = 10; # default 2 10 | $AnyEvent::HTTP::MAX_PER_HOST = 10; # default 10 11 | 12 | my $done = AnyEvent->condvar; 13 | 14 | my ($db, $end, $docs_per) = @ARGV; 15 | unless ($end) { 16 | print STDERR "Usage: couchdb-bench DATABASE COUNT\n"; 17 | exit(1); 18 | } 19 | $docs_per ||= 1; 20 | 21 | my $doc = '{ "me": 1 }'; 22 | my @docs; 23 | my $counter = $docs_per; 24 | push @docs, $doc while $counter--; 25 | $doc = join(',', @docs); 26 | 27 | 28 | my $last; 29 | for (my $n = 1; $n <= $end; $n++) { 30 | my $t = $n; 31 | http_request 'POST', "http://127.0.0.1:5984/$db/_bulk_docs", body => qq{{ "docs": [$doc] }}, sub { 32 | $done->send if $t == $end; 33 | $last = $_[0]; 34 | }; 35 | } 36 | 37 | 38 | my $t0 = [gettimeofday]; 39 | $done->recv; 40 | my $elapsed = tv_interval ( $t0 ); 41 | 42 | my $total = $end * $docs_per; 43 | print "\n\ntotal $total, elapsed $elapsed, rate ", $total/$elapsed, "\n"; 44 | print "Sample output:\n$last\n\n"; 45 | -------------------------------------------------------------------------------- /bin/x-cpan-update: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Updates local CPAN mirror 4 | # 5 | 6 | PATH=$PATH:/usr/local/bin 7 | export PATH 8 | 9 | minicpan $@ 10 | 11 | # Notify end of update 12 | growlnotify -m - -s "CPAN Update" < <>); 5 | -------------------------------------------------------------------------------- /bin/x-curl: -------------------------------------------------------------------------------- 1 | #/bin/sh 2 | 3 | exec curl --write-out "%{url_effective}: %{http_code} time: %{time_total} (DNS %{time_namelookup}, Connct: %{time_connect}, SSL: %{time_appconnect}, Sent: %{time_pretransfer}, First: %{time_starttransfer}) size %{size_download} (headers %{size_header}) avg speed: %{speed_download}\n" -o /dev/null --silent "$@" 4 | -------------------------------------------------------------------------------- /bin/x-datetime-converter: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Getopt::Long; 6 | 7 | my $help; 8 | my $ok = GetOptions("help|?" => \$help); 9 | 10 | usage() if !$ok || $help; 11 | 12 | require_module('DateTime'); 13 | 14 | # Format classes to use for display 15 | my @formats = qw( DateParse MySQL HTTP Mail RSS ); 16 | 17 | # Check for availability of format classes 18 | my @available; 19 | FORMAT_CLASS: 20 | foreach my $format (@formats) { 21 | my $class = "DateTime::Format::$format"; 22 | 23 | next FORMAT_CLASS unless optional_module($class); 24 | 25 | push @available, { 26 | name => $format, 27 | class => $class, 28 | can_parse => $class->can('parse_datetime'), 29 | can_format => $class->can('format_datetime'), 30 | }; 31 | } 32 | 33 | # read dates 34 | while (my $t = <>) { 35 | chomp($t); 36 | my $dt; 37 | 38 | if ($t =~ /^\d+$/) { 39 | $dt = DateTime->from_epoch( epoch => $t ); 40 | } 41 | elsif ($dt = try_helper_parsers($t)) { 42 | # we are done 43 | } 44 | elsif ($t =~ /^(\d\d\d\d)[-\/](\d+)[-\/](\d+)$/) { 45 | $dt = DateTime->new( 46 | year => $1, 47 | month => $2, 48 | day => $3, 49 | ); 50 | } 51 | elsif ($t =~ /^(\d+)[-\/](\d+)[-\/](\d\d\d\d)$/) { 52 | $dt = DateTime->new( 53 | year => $3, 54 | month => $2, 55 | day => $1, 56 | ); 57 | } 58 | elsif ($t =~ /^(\d\d\d\d)[-\/](\d+)[-\/](\d+) (\d+):(\d+):(\d+)$/) { 59 | $dt = DateTime->new( 60 | year => $1, 61 | month => $2, 62 | day => $3, 63 | hour => $4, 64 | minute => $5, 65 | second => $6, 66 | ); 67 | } 68 | elsif ($t =~ /^(\d+)[-\/](\d+)[-\/](\d\d\d\d) (\d+):(\d+):(\d+)$/) { 69 | $dt = DateTime->new( 70 | year => $3, 71 | month => $2, 72 | day => $1, 73 | hour => $4, 74 | minute => $5, 75 | second => $6, 76 | ); 77 | } 78 | elsif ($t =~ /^(\d+):(\d+):(\d+)$/) { 79 | $dt = DateTime->new( 80 | hour => $1, 81 | minute => $2, 82 | second => $3, 83 | ); 84 | } 85 | 86 | if ($dt) { 87 | print " $t -- $dt ", $dt->epoch, " (hex ", sprintf('%0.4x', $dt->epoch) ,")\n"; 88 | foreach my $helper (@available) { 89 | next unless $helper->{can_format}; 90 | print " $t -- format $helper->{name} is: ", $helper->{class}->format_datetime($dt), "\n"; 91 | } 92 | } 93 | else { 94 | print " $t -- could not parse this\n" 95 | } 96 | } 97 | 98 | 99 | #################################################### 100 | # Try the helper classes to parse the datetime given 101 | 102 | sub try_helper_parsers { 103 | my $t = shift; 104 | my $dt; 105 | 106 | foreach my $helper (@available) { 107 | next unless $helper->{can_parse}; 108 | eval { $dt = $helper->{class}->parse_datetime($t) }; 109 | last if $dt; 110 | } 111 | 112 | return $dt; 113 | } 114 | 115 | 116 | ##################################### 117 | # Deal with required/optional modules 118 | 119 | sub require_module { 120 | my $module = shift; 121 | 122 | eval "require $module"; 123 | if (my $e = $@) { 124 | print STDERR "FATAL: $0 requires the Perl module '$module'.\n\n"; 125 | print STDERR "You can install it with:\n\n"; 126 | print STDERR " cpan $module\n\n"; 127 | exit(1); 128 | } 129 | $module->import(@_); 130 | } 131 | 132 | sub optional_module { 133 | my $module = shift; 134 | 135 | eval "require $module"; 136 | return 0 if $@; 137 | 138 | $module->import(@_); 139 | return 1; 140 | } 141 | 142 | ####### 143 | # Usage 144 | 145 | sub usage { 146 | print STDERR <) { 17 | chomp($_); 18 | if ($in_query) { 19 | if (!$_) { $in_query = 0; } 20 | else { $query .= $_; } 21 | next; 22 | } 23 | push @params, $_; 24 | } 25 | } 26 | 27 | my $dbh = DBI->connect($dsn, $user, $pass, { RaiseError => 1 }) || die $DBI::errstr; 28 | my $stm = $dbh->prepare($query); 29 | $stm->execute(@params); 30 | 31 | print join(",", map { "'$_'" } @{$stm->{NAME_uc}}),"\n"; 32 | 33 | while (my @row = $stm->fetchrow_array) { 34 | print join(',', map { tr/\n\r/ /; "'$_'" } @row), "\n"; 35 | } 36 | 37 | $stm->finish; 38 | $dbh->disconnect; 39 | -------------------------------------------------------------------------------- /bin/x-dbi-to-excel: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use DBI; 6 | use Excel::Writer::XLSX; 7 | 8 | 9 | my ($file, $dsn, $user, $pass, $query, @params) = @ARGV; 10 | if (!$file || !$dsn || !$user || length($pass) || !$query) { 11 | die "Usage: x-dbi-to-excel FILENAME DSN USER PASS SQL [bind params]\n"; 12 | } 13 | 14 | map { $_ = undef if $_ && $_ eq 'NULL' } @params; 15 | 16 | if (!$query) { 17 | my $in_query = 1; 18 | while () { 19 | chomp($_); 20 | if ($in_query) { 21 | if (!$_) { $in_query = 0; } 22 | else { $query .= $_; } 23 | next; 24 | } 25 | push @params, $_; 26 | } 27 | } 28 | 29 | my $dbh = DBI->connect($dsn, $user, $pass, { RaiseError => 1 }) || die $DBI::errstr; 30 | my $stm = $dbh->prepare($query); 31 | $stm->execute(@params); 32 | 33 | my ($wrk, $sheet) = create_excel_file($file); 34 | my $col = 0; 35 | $sheet->write(0, $col++, $_) for @{ $stm->{NAME_uc} }; 36 | 37 | my $row = 1; 38 | while (my @row = $stm->fetchrow_array) { 39 | $col = 0; 40 | $sheet->write($row, $col++, $_) for @row; 41 | $row++; 42 | } 43 | 44 | $stm->finish; 45 | $dbh->disconnect; 46 | $wrk->close; 47 | 48 | 49 | sub create_excel_file { 50 | my ($filename) = @_; 51 | 52 | my $wrk = Excel::Writer::XLSX->new($filename); 53 | my $sheet = $wrk->add_worksheet(); 54 | 55 | return ($wrk, $sheet); 56 | } 57 | 58 | 59 | -------------------------------------------------------------------------------- /bin/x-dns-xmpp-records: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | domain=$1 4 | server=$2 5 | export domain server 6 | 7 | ( 8 | # echo srv _xmpp-server._tcp.$domain 9 | dig srv _xmpp-server._tcp.$domain | grep -i srv 10 | # echo srv _xmpp-client._tcp.$domain 11 | dig srv _xmpp-client._tcp.$domain | grep -i srv 12 | # echo srv _jabber._tcp.$domain 13 | dig srv _jabber._tcp.$domain | grep -i srv 14 | # echo srv _jabber-client._tcp.$domain 15 | dig srv _jabber-client._tcp.$domain | grep -i srv 16 | # echo a $domain 17 | dig a $domain | D=$domain perl -ne 'print if /^$ENV{D}.*IN\s+A\s+/' 18 | ) | perl -ne 'next if /^[;.]/ || /^[a-z].root-servers.net./ || /^\s*$/; print' 19 | -------------------------------------------------------------------------------- /bin/x-dns-zerigo-check: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Check a hostname on all Zerigo nameservers 4 | # 5 | # Usefull to track down delays with their dyndns updates, sometimes one 6 | # or two servers are not updated as fast as the others. 7 | # 8 | 9 | if [ -z "$*" ] ; then 10 | echo "Usage: x-dns-zerigo-check host_to_check" 11 | exit 1 12 | fi 13 | 14 | for i in a b c d e f ; do 15 | dig "$@" @${i}.ns.zerigo.net | 16 | ZHOST=$i perl -ne 'next unless /^;; ANSWER SECTION/ .. /^;; (?!ANSWER)/; next if /^(;;.+)?$/; print "$ENV{ZHOST}: $_"' 17 | done 18 | -------------------------------------------------------------------------------- /bin/x-docker-remove-unused-images: -------------------------------------------------------------------------------- 1 | docker rmi -f $(docker images | grep "" | awk "{print \$3}") 2 | -------------------------------------------------------------------------------- /bin/x-dot-check: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use File::Spec::Functions qw( catfile catdir ); 6 | use Cwd qw( realpath ); 7 | 8 | my $home = $ENV{HOME}; 9 | die "FATAL: missing HOME environment\n" unless $home; 10 | 11 | my $rdots = catdir('.dots', 'configs'); 12 | my $dots = catdir($home, $rdots); 13 | die "FATAL: missing dot configuration at '$dots'\n" unless -d $dots; 14 | 15 | 16 | # Read ignore list 17 | my %ignore_dots = read_excludes(catfile($home, '.dotsrc')); 18 | 19 | 20 | # Check the files that should be there 21 | for my $dot (read_templates($dots)) { 22 | $ignore_dots{".$dot"} ||= 'known dots'; 23 | 24 | my $home_dot = catfile($home, ".$dot"); 25 | my $dest_dot = catfile($rdots, $dot); 26 | 27 | if (-l $home_dot) { 28 | my $links_to = readlink($home_dot); 29 | next if $links_to eq $dest_dot; 30 | 31 | print "ERROR: 'HOME/.$dot' is a symblink, but points to '$links_to',\n"; 32 | print " should be '$dest_dot'. Remove it, and\n"; 33 | print " run '$0' again\n"; 34 | } 35 | 36 | if (-e $home_dot) { 37 | print "ERROR: 'HOME/.$dot' exists but its not a symblink:\n"; 38 | print " compare to '$dest_dot',\n"; 39 | print " remove it and run $0 again\n"; 40 | } 41 | else { 42 | symlink($dest_dot, $home_dot) 43 | || die "FATAL: could not symblink() '$dest_dot' to '$home_dot': $!"; 44 | print "Created symlink '$home_dot' => '$dest_dot'\n"; 45 | } 46 | } 47 | 48 | 49 | # Check the files we don't know nothing about 50 | for my $dot (read_dots($home)) { 51 | next if exists $ignore_dots{$dot}; 52 | 53 | print "WARN: dot file '$dot' in HOME is unknown\n"; 54 | } 55 | 56 | 57 | # Utilities 58 | sub read_dots { 59 | my ($dir) = @_; 60 | my @dots; 61 | 62 | opendir(my $dh, $dir) || die "FATAL: could not list directory '$dir': $!\n"; 63 | while (my $dot = readdir($dh)) { 64 | push @dots, $dot if $dot =~ /^[.]\w/; 65 | } 66 | closedir($dh); 67 | 68 | return @dots; 69 | } 70 | 71 | sub read_templates { 72 | my ($dir) = @_; 73 | my @dots; 74 | 75 | opendir(my $dh, $dir) || die "FATAL: could not list directory '$dir': $!\n"; 76 | while (my $dot = readdir($dh)) { 77 | push @dots, $dot unless $dot =~ /^[.]/; 78 | } 79 | closedir($dh); 80 | 81 | return @dots; 82 | } 83 | 84 | sub read_excludes { 85 | my ($file) = @_; 86 | 87 | open(my $fh, '<', $file) or return; 88 | 89 | my %dots; 90 | while (<$fh>) { 91 | s/^\s+|\s+$//g; 92 | next unless $_; 93 | next if /^#/; 94 | 95 | $dots{$_} = 'ignore'; 96 | } 97 | 98 | return %dots; 99 | } 100 | -------------------------------------------------------------------------------- /bin/x-email-extract-html-part: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Courriel; 6 | 7 | binmode(\*STDOUT, 'encoding(UTF-8)'); 8 | 9 | my $raw_email = do { 10 | local $/; 11 | <>; 12 | }; 13 | 14 | my $m = Courriel->parse(text => $raw_email); 15 | my $html = $m->html_body_part; 16 | print $html->content; 17 | -------------------------------------------------------------------------------- /bin/x-evolui-timeline: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | 4 | cd ~/work/evolui && exec x-git-timeline E1=e1 Gestao=gestao E5=e5 Forums=e3 Admin=e2 Misc=false_start -- $@ 5 | -------------------------------------------------------------------------------- /bin/x-excel-compare: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Compare two excel sheets 4 | # 5 | 6 | use strict; 7 | use warnings; 8 | use Spreadsheet::XLSX; 9 | use Getopt::Long; 10 | 11 | my $is_diff = 0; 12 | my %opts; 13 | GetOptions(\%opts, "file1=s", "key1=i", "file2=s", "key2=i", "has-headers", "ignore-whitespace|b", "debug", "help",) 14 | or usage('Bad options'); 15 | usage('Help wanted') if $opts{help}; 16 | 17 | 18 | for ($opts{file1}, $opts{file2}) { 19 | usage("Cannot read file '$_'") unless -r $_; 20 | } 21 | 22 | 23 | my $excel1 = Spreadsheet::XLSX->new($opts{file1}); 24 | my ($sheet1) = @{ $excel1->{Worksheet} }; 25 | 26 | my $excel2 = Spreadsheet::XLSX->new($opts{file2}); 27 | my ($sheet2) = @{ $excel2->{Worksheet} }; 28 | 29 | my $row = $sheet1->{MinRow}; 30 | if ($opts{'has-headers'}) { 31 | my $equal = compare_row($row, $sheet1, $sheet2); 32 | exit(5) if $is_diff; 33 | $row++; 34 | } 35 | 36 | my $max = $sheet1->{MaxRow}; 37 | if ($max != $sheet2->{MaxRow}) { 38 | diff($row, undef, "different row counts - $max and $sheet2->{MaxRow}"); 39 | $max = $sheet2->{MaxRow} if $max > $sheet2->{MaxRow}; 40 | } 41 | 42 | while ($row < $max) { 43 | compare_row($row, $sheet1, $sheet2); 44 | $row++; 45 | } 46 | 47 | debug("Found $is_diff differences"); 48 | 49 | exit($is_diff ? 5 : 0); 50 | 51 | 52 | sub compare_row { 53 | my ($row, $sheet1, $sheet2) = @_; 54 | 55 | my @r1 = extract_row_from($row, $sheet1); 56 | my @r2 = extract_row_from($row, $sheet2); 57 | 58 | debug("* Comparing row '$row'"); 59 | my $l1 = @r1; 60 | my $l2 = @r2; 61 | if ($l1 != $l2) { 62 | diff($row, undef, "different lengths - $l1 and $l2"); 63 | $l1 = $l2 if $l2 < $l1; 64 | } 65 | 66 | my $col = $sheet1->{MinCol}; 67 | while ($col < $l1) { 68 | my ($v1, $v2) = ($r1[$col], $r2[$col]); 69 | 70 | $v1 = defined $v1 ? "'$v1'" : ''; 71 | $v2 = defined $v2 ? "'$v2'" : ''; 72 | 73 | if ($v1 eq $v2) { 74 | debug("... ", _prefix($row, $col), ": equal $v1 == $v2"); 75 | } 76 | else { 77 | diff($row, $col, "$v1 <=> $v2"); 78 | } 79 | 80 | $col++; 81 | } 82 | } 83 | 84 | sub extract_row_from { 85 | my ($row, $sheet) = @_; 86 | 87 | my @data; 88 | for (my $col = $sheet->{MinCol}; $col <= $sheet->{MaxCol}; $col++) { 89 | my $v = $sheet->{Cells}[$row][$col]; 90 | if ($v and defined $v->{Val}) { 91 | push @data, $v->{Val}; 92 | if ($opts{'ignore-whitespace'}) { 93 | $data[-1] =~ s/^\s+|\s+$//; 94 | $data[-1] =~ s/\s+/ /g; 95 | } 96 | } 97 | else { 98 | push @data, undef; 99 | } 100 | } 101 | 102 | return @data; 103 | } 104 | 105 | sub diff { 106 | my ($r, $c, @rest) = @_; 107 | my $prefix = _prefix($r, $c) . ': '; 108 | 109 | print $prefix, @rest, "\n"; 110 | debug("... ", $prefix, @rest); 111 | 112 | $is_diff++; 113 | } 114 | 115 | sub debug { 116 | return unless $opts{debug}; 117 | print STDERR @_, "\n"; 118 | } 119 | 120 | sub _prefix { 121 | my ($r, $c) = @_; 122 | 123 | my $prefix = "r$r"; 124 | $prefix .= ":c$c" if defined $c; 125 | 126 | return $prefix; 127 | } 128 | 129 | sub usage { 130 | print STDERR "FATAL: ", @_, "\n" if @_; 131 | print STDERR "Usage: x-excel-compare --file1=FILE1 --file2=FILE2 [--has-headers] [--ignore-whitespace] [--help]"; 132 | exit(1); 133 | } 134 | -------------------------------------------------------------------------------- /bin/x-filter-strip-trailing-whitespace: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | while (<>) { 4 | s/[ \t]+$//m; 5 | print 6 | } 7 | -------------------------------------------------------------------------------- /bin/x-gen-crypt-pass: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Generated an encrypted password using Crypt::PBKDF2 4 | # 5 | 6 | use strict; 7 | use warnings; 8 | use Crypt::PBKDF2; 9 | 10 | my ($password) = @ARGV; 11 | if (!$password) { 12 | my $is_tty = -t \*STDIN; 13 | 14 | print "Type your password:\n" if $is_tty; 15 | $password = <>; 16 | chomp($password); 17 | 18 | if ($is_tty) { 19 | print "Type it again:\n"; 20 | my $check = <>; 21 | chomp($check); 22 | 23 | die "Password mismatch\n" if $password ne $check; 24 | } 25 | } 26 | 27 | print Crypt::PBKDF2->new->generate($password), "\n"; 28 | -------------------------------------------------------------------------------- /bin/x-git-changelog: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec git log --no-merges --pretty=format:' * %s (%an)' $@ | perl -pe 's/ [()]Pedro Melo[)]$//' 4 | -------------------------------------------------------------------------------- /bin/x-git-open-in-github: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # 3 | # 4 | 5 | use strict; 6 | use warnings; 7 | 8 | die "ERROR: could not exec git remote -v\n" 9 | unless open(my $gr, '-|', 'git remote -v'); 10 | 11 | while (<$gr>) { 12 | next unless m{\s+.+?github.com[:/](.*)/(.*)[.]git\s}; 13 | exec("open http://github.com/$1/$2"); 14 | } 15 | 16 | print "Project does not seem to be hosted at github\n"; 17 | 18 | -------------------------------------------------------------------------------- /bin/x-git-timeline: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # x-git-timeline: generate a simple one HTML page site with commits of 4 | # several git projects merged together, ordered by commit date 5 | # 6 | # Usage: x-git-timeline path_to_repo1 path_to_repo2 [-- [git log options]] > timeline.html 7 | # 8 | # The path_to_repoN options can be: 9 | # * a simple path to a repo, like some/path/to/repo 10 | # * a name and a path to the repo, like repo_name=some/path/to/repo. 11 | # 12 | # Each commit in the output is tagged with the name of the repo. If none 13 | # was provided, we use the basename of the path. 14 | # 15 | # You can provide extra git-log options, like --since="2 days ago" but 16 | # remember that if you merge an older branch in the last 2 days some of 17 | # those old commits will be shown. Another usefull option 18 | # is --author="me". 19 | # 20 | # I wrote this because over the course of a week, I commit to several 21 | # repositories of work projects, pet projects, other peoples 22 | # projects, and I wanted to get a feel of where I worked on in the 23 | # past couple of days 24 | # 25 | # Author: Pedro Melo 26 | # 27 | # License: Artistic License 2.0 28 | # 29 | # TODO: stop using cmd line sort do it internaly 30 | # 31 | # Changelog: https://github.com/melo/scripts/commits/master/bin/x-git-timeline 32 | 33 | use strict; 34 | 35 | 36 | my ($repos, $git_log_opts) = _parse_cmd_line(); 37 | my $fh = _build_cmd_line($repos, $git_log_opts); 38 | generate_report($fh); 39 | 40 | sub generate_report { 41 | my ($fh) = @_; 42 | 43 | my $cur_date = ''; 44 | while (my $raw = <$fh>) { 45 | my ($ts, $repo, $hash, $subject) = $raw =~ m/^(\d+)\s+(\S+)\s+([a-f0-9]+)\s+(.*)$/; 46 | 47 | my ($year, $month, $day, $hour, $min) = (localtime($ts))[5, 4, 3, 2, 1]; 48 | my $date = sprintf('%.4d/%0.2d/%0.2d', $year + 1900, $month + 1, $day); 49 | 50 | if ($date ne $cur_date) { 51 | $cur_date = $date; 52 | print "\n$cur_date:\n"; 53 | } 54 | 55 | printf(' %0.2d:%0.2d: (%s) - %s [%s]%s', $hour, $min, $repo, $subject, substr($hash, 0, 7), "\n"); 56 | } 57 | } 58 | 59 | 60 | sub _build_cmd_line { 61 | my ($repos, $git_log_opts) = @_; 62 | 63 | my $cmd_line = 'sort -rn '; 64 | for my $r (@$repos) { 65 | $cmd_line .= qq{ <( cd "$r->{path}" && git log "--pretty=format:%at $r->{name} %H %s" --branches $git_log_opts )}; 66 | } 67 | $cmd_line = "bash -c '$cmd_line'"; 68 | 69 | open(my $commit_fh, '-|', $cmd_line) or die "Failed to exec '$cmd_line': $!"; 70 | return $commit_fh; 71 | } 72 | 73 | sub _parse_cmd_line { 74 | my @repos; 75 | while (defined(my $i = shift @ARGV)) { 76 | last if $i eq '--'; 77 | $i =~ m!^(([^=]+)=)?(.*?([^/]+))$!; 78 | push @repos, { path => $3, name => $2 || $4 }; 79 | } 80 | 81 | return (\@repos, join(' ', map {qq{"$_"}} @ARGV)); 82 | } 83 | 84 | -------------------------------------------------------------------------------- /bin/x-git-to-doc-website: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Converts github-style perl project to a documentation website 4 | # 5 | # Index page is taken from the README.md page. 6 | # 7 | # All .pm files are searched for POD and converted to HTML. 8 | # Everything is dumped to the required output directory parameter. 9 | # 10 | 11 | package Project::Converter::Perl; 12 | 13 | use Moo; 14 | use Path::Tiny; 15 | use Getopt::Long; 16 | use Text::Markdown 'markdown'; 17 | 18 | has 'source' => (is => 'ro', required => 1); 19 | has 'output' => (is => 'ro', required => 1); 20 | 21 | sub run { 22 | my ($self) = @_; 23 | 24 | my @pod_files = $self->collect_perl_files_with_pod; 25 | $self->convert_file_with_pod($_) for @pod_files; 26 | 27 | $self->convert_readme(\@pod_files); 28 | } 29 | 30 | sub collect_perl_files_with_pod { 31 | return (); 32 | } 33 | 34 | sub convert_file_with_pod { 35 | ...; 36 | } 37 | 38 | sub convert_readme { 39 | my ($self, $pod_files) = @_; 40 | 41 | my $readme = $self->source->child('README.md'); 42 | return unless $readme->is_file; 43 | 44 | my $html = markdown($readme->slurp); 45 | $self->output->child('index.html')->spew($html); 46 | } 47 | 48 | sub new_from_options { 49 | my ($class) = @_; 50 | 51 | my %opts; 52 | GetOptions(\%opts, 'output=s', 'help|?') or usage(); 53 | usage() if exists $opts{help} and $opts{help}; 54 | usage('more than one source directory given') if @ARGV > 1; 55 | usage('output parameter is required') unless $opts{output}; 56 | 57 | $opts{source} = @ARGV? $ARGV[0] : '.'; 58 | 59 | $opts{$_} = path($opts{$_}) for qw( source output ); 60 | return $class->new(%opts); 61 | } 62 | 63 | sub usage { 64 | print STDERR "FATAL: @_\n" if @_; 65 | 66 | print STDERR "Usage: x-git-to-doc-website --output= []\n"; 67 | exit(1); 68 | } 69 | 70 | 71 | 72 | package main; 73 | 74 | Project::Converter::Perl->new_from_options->run; 75 | -------------------------------------------------------------------------------- /bin/x-git-update-to-latest-version: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Updates you git.git clone, recompiles, installs and activates the latest 4 | # version 5 | # 6 | 7 | # Set this to the place where git.git clone is at 8 | # in you local filesystem 9 | GIT_CLONE_DIR=$HOME/projects/essentials/git 10 | 11 | # Where all the git versions will be placed 12 | # Each version will be inside a directory, like git-v1.5.6.1-204-g6991357 13 | # Current active version will be a symblink 'git' 14 | # so you can add $BASE/git/bin to your PATH 15 | BASE=$HOME/.apps/git-versions 16 | 17 | ### Nothing more to tweak ### 18 | 19 | ## local::lib installs might mess up with /usr/bin/perl 20 | ## if you have another perl on your path 21 | unset PERL_MM_OPT 22 | unset PERL5LIB 23 | 24 | cd $GIT_CLONE_DIR 25 | if [ $? != 0 ] ; then 26 | echo 27 | echo "** FATAL **: could not chdir to GIT_CLONE_DIR $GIT_CLONE_DIR" 28 | echo "Edit this script and tell me where the git.git clone is" 29 | exit 1 30 | fi 31 | 32 | # Allow for -t to force a make test 33 | # I should learn to use getopt with sh really 34 | run_tests= 35 | if [ "$1" == "-t" ] ; then 36 | run_tests=yes 37 | fi 38 | 39 | if [ -z "$DOIT" ] ; then 40 | echo 41 | echo "This script will pull the lastest git.git master branch, recompile," 42 | echo "install and activate." 43 | echo 44 | echo "Sure? [y/N]" 45 | 46 | read confirmation 47 | 48 | if [ "$confirmation" != "y" ] ; then exit ; fi 49 | fi 50 | 51 | if [ -e configure ] ; then 52 | make distclean 53 | fi 54 | 55 | git fetch 56 | git merge --ff --no-edit origin/master 57 | 58 | version=`git describe --always` 59 | 60 | if [ -z "$DOIT" -a -d "$BASE/git-$version" ] ; then 61 | echo 62 | echo "**** You already have the latest git version ($version) installed" 63 | echo 64 | exit 0 65 | fi 66 | 67 | echo 68 | echo "******* Compiling version $version" 69 | echo 70 | 71 | PERL_PATH="/usr/bin/env perl" 72 | export PERL_PATH 73 | 74 | XML_CATALOG_FILES=`brew --prefix`"/etc/xml/catalog" 75 | export XML_CATALOG_FILES 76 | 77 | make configure 78 | ./configure --prefix=$BASE/git-$version 79 | make -j6 all 80 | if [ $? != 0 ] ; then 81 | echo "******* Compilation failed! " 82 | exit 1 83 | fi 84 | 85 | make doc 86 | if [ $? != 0 ] ; then 87 | echo "******* Documentation generation failed! " 88 | exit 1 89 | fi 90 | 91 | if [ "$run_tests" == "yes" ] ; then 92 | echo 93 | echo "******* Running test suite" 94 | echo 95 | 96 | make test 97 | fi 98 | 99 | echo 100 | echo "******* Installing git and documentation" 101 | echo 102 | 103 | make install install-doc install-man install-html 104 | 105 | 106 | echo 107 | echo "******* Cleanup phase" 108 | echo 109 | 110 | make distclean 111 | git gc 112 | 113 | 114 | echo 115 | echo "******* Check environment" 116 | echo 117 | 118 | check_path=`echo $PATH | perl -pe 's/:/\n/g' | egrep ^$BASE/git/bin$` 119 | if [ -z "$check_path" ] ; then 120 | echo 121 | echo "WARNING: your PATH must be changed to include" 122 | echo 123 | echo " $BASE/git/bin" 124 | echo 125 | fi 126 | 127 | check_manpath=`echo $MANPATH | perl -pe 's/:/\n/g' | egrep ^$BASE/git/share/man$` 128 | if [ -z "$check_manpath" ] ; then 129 | echo 130 | echo "WARNING: your MANPATH must be changed to include" 131 | echo 132 | echo " $BASE/git/share/man" 133 | echo 134 | fi 135 | 136 | echo 137 | echo Current git version: `readlink $BASE/git` 138 | echo Switching to version: git-$version 139 | echo 140 | 141 | cd $BASE; 142 | rm -f git; 143 | ln -s git-$version git; 144 | 145 | echo 146 | echo "You are running verion (running git -v now):" 147 | echo 148 | git --version 149 | 150 | -------------------------------------------------------------------------------- /bin/x-hipchat: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use JSON 'encode_json'; 6 | use HTTP::Tiny; 7 | use Getopt::Long; 8 | use Encode 'decode'; 9 | 10 | my %opts = (room => $ENV{HIPCHAT_ROOM}, notify => 1); 11 | GetOptions(\%opts, 'help', 'room=s', 'notify!', 'color=s', 'message_format=s') or usage(); 12 | usage() if $opts{help}; 13 | 14 | usage("room is required parameter\n") unless $opts{room}; 15 | usage("ENV HIPCHAT_TOKEN is required\n") unless my $hipchat_token = $ENV{HIPCHAT_TOKEN}; 16 | 17 | -t \*STDOUT and -t \*STDIN and print "Type your message, enter ^D to send, ^C to abort:\n"; 18 | my $message = ''; 19 | while (length($message) <= 10_000 and my $line = <>) { $message .= decode('UTF-8', $line) } 20 | 21 | usage("no message to send\n") unless length($message); 22 | usage("message to big (max 10_000 chars)\n") if length($message) > 10_000; 23 | 24 | my %body = (message => $message); 25 | $body{color} = $opts{color} if $opts{color}; 26 | $body{notify} = \1 if $opts{notify}; 27 | $body{message_format} = $opts{message_format} || 'text'; 28 | 29 | my $res = HTTP::Tiny->new(ua => 'x-hipchat ')->post( 30 | "https://api.hipchat.com/v2/room/$opts{room}/notification", 31 | { headers => { 32 | 'Authorization' => "Bearer $hipchat_token", 33 | 'Content-Type' => 'application/json', 34 | }, 35 | content => encode_json(\%body), 36 | } 37 | ); 38 | exit(0) if $res->{status} == 204; 39 | 40 | print "Ooops - $res->{status} $res->{reason}: $res->{content}\n"; 41 | exit(1); 42 | 43 | 44 | sub usage { 45 | print "ERROR: @_\n" if @_; 46 | 47 | print <new->post('http://127.0.0.1/', { content => JSON::encode_json({}) }) }; 67 | } 68 | } 69 | -------------------------------------------------------------------------------- /bin/x-html-escape: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | while (<>) { 7 | s/&/&/g; 8 | s//>/g; 10 | s/'/"/g; 11 | 12 | print; 13 | } 14 | -------------------------------------------------------------------------------- /bin/x-html-use-my-css: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # 3 | # filter: reads stdin, dumps to stdout. 4 | # puts std html stuff with my_css around html input 5 | # usefull with Markdow.pl file | this_script > destination 6 | # 7 | 8 | use strict; 9 | 10 | print < 12 | 13 | 14 | 15 | 16 | EOF 17 | 18 | print while(<>); 19 | 20 | print < 22 | 23 | EOF 24 | -------------------------------------------------------------------------------- /bin/x-http-proxy-start-port-8469: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec tinyproxy -d -c "$HOME/.scripts.d/etc/tinyproxy.conf" 4 | -------------------------------------------------------------------------------- /bin/x-http-recorder: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use HTTP::Proxy; 4 | use HTTP::Recorder; 5 | 6 | my $proxy = HTTP::Proxy->new(); 7 | $proxy->port(3128); 8 | $proxy->max_connections(20); 9 | 10 | # create a new HTTP::Recorder object 11 | my $agent = HTTP::Recorder->new; 12 | 13 | # set the log file (optional) 14 | $agent->file("/tmp/http-recorder.log"); 15 | 16 | # set HTTP::Recorder as the agent for the proxy 17 | $proxy->agent( $agent ); 18 | 19 | # start the proxy 20 | $proxy->start(); 21 | 22 | 1; 23 | -------------------------------------------------------------------------------- /bin/x-https-certificate-dump: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | echo | openssl s_client -connect $1 2>/dev/null | openssl x509 -text 4 | -------------------------------------------------------------------------------- /bin/x-import-db-codigo-postal-pt: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Getopt::Long; 6 | use utf8; 7 | 8 | binmode(\*STDOUT, ':utf8'); 9 | 10 | my %args; 11 | my $ok = GetOptions(\%args, 12 | qw( db=s user=s password=s deploy )); 13 | 14 | my $db = $args{db}; 15 | 16 | usage() unless $ok; 17 | #usage() unless $db; 18 | 19 | #$db = "dbi:mysql:$db" unless $db =~ /^dbi:/; 20 | 21 | my $dbh; 22 | 23 | 24 | 25 | load_todos_cp(); 26 | 27 | 28 | sub load_todos_cp { 29 | open(my $fh, '<', 'todos_cp.txt') or die "Could not find file 'todos_cp.txt', "; 30 | 31 | while (my $row = <$fh>) { 32 | chomp($row); 33 | my ($d_id, $c_id, $l_id, $l, $a_id, $a_tipo, $a_pp, $a_t, $a_sp, $a_d, $a_l, $a_tr, $a_p, $cln, $cp4, $cp3, $cpa) = split(/;/, $row); 34 | print "$cp4\n" if $d_id == 1 || $d_id == 06 || $d_id == 10; 35 | # print "$cp4-$cp3: $cln\n" if $cln; 36 | } 37 | } 38 | 39 | 40 | sub deploy { 41 | $dbh->do(q{ 42 | CREATE TABLE cod_postal ( 43 | id integer not null primary key auto_increment, 44 | distrito_id byte not null, 45 | concelho_id byte not null, 46 | localidade_id integer not null, 47 | 48 | localidade varchar(100) not null, 49 | 50 | ) 51 | }) 52 | } -------------------------------------------------------------------------------- /bin/x-itunes-decrypt-all: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | 4 | 5 | use strict; 6 | use warnings; 7 | 8 | while (my $line = <>) { 9 | if ($line !~ m{Locationfile://localhost(.+?.m4p)}) { 10 | print $line; 11 | next; 12 | } 13 | 14 | my $file = $1; 15 | $file =~ s{%(..)}{chr(hex($1))}ge; 16 | 17 | my $dest = $file; 18 | $dest =~ s/[.]m4p$/.m4a/; 19 | 20 | if (-e $file && -e $dest) { 21 | print STDERR "Unlink $file\n"; 22 | unlink($file); 23 | } 24 | 25 | $line =~ s{[.]m4p}{.m4a} if -e $dest; 26 | print $line; 27 | } 28 | -------------------------------------------------------------------------------- /bin/x-javascript-create-bookmarklet: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # http://daringfireball.net/2007/03/javascript_bookmarklet_builder 4 | 5 | use strict; 6 | use warnings; 7 | use URI::Escape qw(uri_escape_utf8); 8 | use open IO => ":utf8", # UTF8 by default 9 | ":std"; # Apply to STDIN/STDOUT/STDERR 10 | 11 | my $src = do { local $/; <> }; 12 | 13 | # Zap the first line if there's already a bookmarklet comment: 14 | $src =~ s{^// ?javascript:.+\n}{}; 15 | my $bookmarklet = $src; 16 | 17 | for ($bookmarklet) { 18 | s{^\s*//.+\n}{}gm; # Kill comments. 19 | s{\t}{ }gm; # Tabs to spaces 20 | s{[ ]{2,}}{ }gm; # Space runs to one space 21 | s{^\s+}{}gm; # Kill line-leading whitespace 22 | s{\s+$}{}gm; # Kill line-ending whitespace 23 | s{\n}{}gm; # Kill newlines 24 | } 25 | 26 | # Escape single- and double-quotes, spaces, control chars, unicode: 27 | $bookmarklet = "javascript:" . 28 | uri_escape_utf8($bookmarklet, qq('" \x00-\x1f\x7f-\xff)); 29 | 30 | print "// $bookmarklet\n" . $src; 31 | 32 | # Put bookmarklet on clipboard: 33 | `/bin/echo -n '$bookmarklet' | /usr/bin/pbcopy`; 34 | -------------------------------------------------------------------------------- /bin/x-js-minifier: -------------------------------------------------------------------------------- 1 | #!/Users/gugod/local/bin/perl 2 | #!/usr/bin/env perl 3 | use JavaScript::Minifier::XS qw(minify); 4 | undef $/; 5 | print minify(<>); 6 | -------------------------------------------------------------------------------- /bin/x-json-parse: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use JSON::XS; 6 | use Data::Dump qw( dd ); 7 | use encoding 'utf8'; 8 | 9 | my $file = $ARGV[0]; 10 | if (!$file) { 11 | warn("Usage: x-json-parse FILE\n"); 12 | exit(1); 13 | } 14 | 15 | open(my $fh, '<:utf8', $file); 16 | die("ERROR: could not open file '$file'\n") unless $fh; 17 | 18 | local $/; 19 | my $json = <$fh>; 20 | close($fh); 21 | 22 | binmode(\*STDOUT, ':utf8'); 23 | eval { 24 | dd(decode_json($json)); 25 | }; 26 | die if $@; 27 | 28 | exit(0); 29 | 30 | 31 | -------------------------------------------------------------------------------- /bin/x-links-to-relative: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # 4 | 5 | use strict; 6 | use warnings; 7 | use Path::Class 'dir'; 8 | 9 | my ($base) = @ARGV; 10 | die "Usage: x-links-to-relative \n" unless $base && -d $base; 11 | 12 | chdir($base) || die "FATAL: could not chdir to '$base' - $!\n"; 13 | 14 | # Path::Class::Dir 15 | $base = dir($base); 16 | 17 | $base->recurse(callback => sub { 18 | my ($o) = @_; 19 | my $f = $o->stringify; 20 | return unless -l $f; 21 | 22 | my $dst = dir(readlink($f)); 23 | my $bn = $dst->basename; 24 | 25 | print "O: $o D: $dst N: $bn\n"; 26 | unlink($f); 27 | symlink($bn, $f); 28 | }); 29 | -------------------------------------------------------------------------------- /bin/x-logbook: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | host=`hostname -s` 4 | 5 | mate ~/Documents/work/personal/dotfiles/.logbook-${host}.md ~/Documents/work/personal/dotfiles/.logbook-*.md 6 | -------------------------------------------------------------------------------- /bin/x-mac-hosts-edit: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | sudo vim /etc/hosts 4 | sudo /usr/bin/dscacheutil -flushcache 5 | 6 | -------------------------------------------------------------------------------- /bin/x-mac-ramdisk: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # Creates a RAM disk in Mac OS X 4 | # 5 | # Copied from http://pastie.textmate.org/private/igcxuzqqvlmlbavxooj2uw 6 | # by @antirez 7 | 8 | ramfs_size_mb=1024 9 | mount_point=~/volatile 10 | 11 | ramfs_size_sectors=$((${ramfs_size_mb}*1024*1024/512)) 12 | ramdisk_dev=`hdid -nomount ram://${ramfs_size_sectors}` 13 | newfs_hfs -v 'Volatile' ${ramdisk_dev} 14 | mkdir -p ${mount_point} 15 | mount -o noatime -t hfs ${ramdisk_dev} ${mount_point} 16 | echo "remove with:" 17 | echo "umount ${mount_point}" 18 | echo "diskutil eject ${ramdisk_dev}" -------------------------------------------------------------------------------- /bin/x-map-network-connections-mesh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Collects a lot of data to map the network connections between a set of servers 4 | # 5 | 6 | use strict; 7 | use Carp qw( croak ); 8 | use Data::Dumper; 9 | use GraphViz; 10 | use Log::Log4perl qw(:easy); 11 | Log::Log4perl->easy_init($WARN); 12 | 13 | my $map = foreach_line(\&parse_command_output); 14 | 15 | #WARN('Map after parsing is: ', Dumper($map)); 16 | #exit(0); 17 | 18 | 19 | ### NEXT STEPS: o pid é local ao server, por cada conn temos de ter o r_name 20 | # e l_name 21 | # uma maneira é na passagem pelo netstat manter um hash com key 22 | # $server:l_addr:l_port:l_proto => { pid, short_name } que depois expandimos 23 | # para name cruzando com o /service 24 | # 25 | 26 | my $g = GraphViz->new( 27 | layout => 'dot', 28 | node => { shape => 'box' }, 29 | ); 30 | 31 | # Create a list of IP addresses per server 32 | my %ip_map = %{$map->{ip}}; 33 | while (my ($ip, $name) = each %{$map->{ip}}) { 34 | push @{$ip_map{$name}}, $ip; 35 | } 36 | 37 | # create a local hash with open ports on each server, and name all socket connections 38 | my %open_ports; 39 | walk( 40 | $map->{netstat}, 41 | sub { 42 | my ($item, @path) = @_; 43 | my $server = $path[0]; 44 | 45 | return unless UNIVERSAL::isa($item => 'HASH'); 46 | return unless $item->{pid}; 47 | return unless $item->{proto} eq 'tcp'; # We currently don't use UDP 48 | 49 | $item->{server} = $server; 50 | $item->{name} = 51 | ($item->{pid} && $map->{slash_services}{$server}{$item->{pid}}) 52 | || $item->{short_name} 53 | || '???'; 54 | 55 | return unless exists $item->{port}; 56 | 57 | foreach my $ip (@{$ip_map{$server}}) { 58 | $open_ports{"$ip:$item->{port}:$item->{proto}"} = { item => $item, used => 0 }; 59 | } 60 | } 61 | ); 62 | 63 | # scan all connections, and see which ones are in use. Collect edges 64 | my @edges; 65 | my %nodes; 66 | walk( 67 | $map->{netstat}, 68 | sub { 69 | my ($item, @path) = @_; 70 | my $server = $path[0]; 71 | 72 | return unless UNIVERSAL::isa($item => 'HASH'); 73 | return unless $item->{state} eq 'ESTABLISHED'; 74 | return unless $item->{proto} eq 'tcp'; 75 | return unless exists $ip_map{$item->{l_addr}} && exists $ip_map{$item->{r_addr}}; 76 | 77 | # src, dst 78 | my ($bare_server) = $item->{server} =~ m/^([^.]+)/; 79 | 80 | my @conn_info = ( 81 | { 82 | key => qq{$item->{l_addr}:$item->{l_port}:$item->{proto}}, 83 | srv => $ip_map{$item->{l_addr}}, 84 | name => qq{$item->{l_name}:$item->{l_port}}, 85 | }, 86 | { 87 | key => qq{$item->{r_addr}:$item->{r_port}:$item->{proto}}, 88 | srv => $ip_map{$item->{r_addr}}, 89 | name => qq{$item->{r_name}:$item->{r_port}}, 90 | }, 91 | ); 92 | 93 | # check which side of the conn is the server, swap if need, mark server as used 94 | my ($l_key, $r_key) = ($conn_info[0]{key}, $conn_info[1]{key}); 95 | 96 | if (exists $open_ports{$l_key}) { 97 | $open_ports{$l_key}{used}++; 98 | ($conn_info[0], $conn_info[1]) = ($conn_info[1], $conn_info[0]); # swap direction of edge 99 | } 100 | elsif (exists $open_ports{$r_key}) { 101 | $open_ports{$r_key}{used}++ 102 | } 103 | else { 104 | return; # this should not happen :) 105 | } 106 | 107 | push @edges, { src => $conn_info[0]{srv} }; 108 | push @{$nodes{$bare_server}{labels}}, $conn_info[1]{name}; 109 | } 110 | ); 111 | use Data::Dumper; print STDERR ">>>>>> ", Dumper(\%nodes); 112 | 113 | # Scan ports in use: create nodes 114 | walk( 115 | \%nodes, 116 | sub { 117 | my ($item, $server) = @_; 118 | 119 | return unless UNIVERSAL::isa($item => 'HASH'); 120 | return unless $item->{labels}; 121 | 122 | $g->add_node($server, headlabel => $server, label => $nodes{$server}); 123 | } 124 | ); 125 | 126 | 127 | print $g->as_canon; 128 | 129 | ########## 130 | # Parsing 131 | 132 | sub parse_command_output { 133 | my ($line, $map) = @_; 134 | 135 | # ignore empty lines 136 | return if $line =~ /^\s*$/; 137 | 138 | # ouput has section, this is the start of a section 139 | if ($line =~ /^\s*--- (.+) ---/) { 140 | INFO("Found section '$1'"); 141 | $map->{current_section} = $1; 142 | return; 143 | } 144 | 145 | # each section reports on several server 146 | if ($line =~ /^Server (\S+):$/) { 147 | INFO("Found server '$1'"); 148 | $map->{current_server} = $1; 149 | return; 150 | } 151 | my ($server, $section) = @{$map}{qw(current_server current_section)}; 152 | 153 | LOGCROAK("Got content line but no section active: $line") if $line && !$section; 154 | LOGCROAK("Got content line but no server active: $line") if $line && !$server; 155 | 156 | # DEBUG("current line ($section/$server): $line"); 157 | 158 | my $l_map = $map->{$section}{$server} ||= {}; 159 | if ($section eq 'interfaces') { _parse_interfaces($line, $server, $l_map, $map); } 160 | elsif ($section eq 'slash_services') { _parse_proc_names($line, $server, $l_map, $map); } 161 | elsif ($section eq 'netstat') { _parse_netstat($line, $server, $l_map, $map); } 162 | } 163 | 164 | sub _parse_interfaces { 165 | my ($line, $server, $map, $gmap) = @_; 166 | 167 | if ($line =~ /^(\S+)/) { 168 | $map->{current_interface} = $1; 169 | INFO("Found interface '$1'") 170 | } 171 | my $iface = $map->{current_interface}; 172 | 173 | if ($line =~ /inet addr:(\d+\.\d+\.\d+\.\d+)/) { 174 | INFO("Found IP address '$1'"); 175 | $map->{$iface} = $1; 176 | $map->{$1} = $iface; 177 | $gmap->{ip}{$1} = $server unless substr($1, 0, 4) eq '127.'; 178 | } 179 | } 180 | 181 | sub _parse_proc_names { 182 | my ($line, $server, $map, $gmap) = @_; 183 | 184 | if ($line =~ m{^/service/(.+?): up .pid (\d+)}) { 185 | $map->{$2} = $1; 186 | $map->{$1} = $2; 187 | INFO("Found service '$1' with pid '$2'"); 188 | } 189 | } 190 | 191 | sub _parse_netstat { 192 | my ($line, $server, $map, $gmap) = @_; 193 | 194 | # Active Internet connections (servers and established) 195 | return if $line =~ /^Active Internet connections/; 196 | 197 | # Proto Recv-Q Send-Q Local Address Foreign Address State PID/Program name 198 | return if $line =~ /Proto\s+Recv-Q\s+Send-Q/; 199 | 200 | # Active UNIX domain sockets (servers and established) 201 | return if $line =~ /^Active UNIX domain sockets/; 202 | 203 | # Proto RefCnt Flags Type State I-Node PID/Program name Path 204 | return if $line =~ /^Proto RefCnt Flags/; 205 | 206 | 207 | # tcp 0 0 0.0.0.0:25 0.0.0.0:* LISTEN 344/tcpserver 208 | if ($line =~ m{^tcp\s+\d+\s+\d+\s+(\d+\.\d+\.\d+\.\d+):(\d+).+(LISTEN)\s+(\d+)/(.+)}) { 209 | my $data = { proto => 'tcp', addr => $1, port => $2, state => $3, pid => $4, short_name => $5 }; 210 | my $open_sock = $map->{open_sock} ||= []; 211 | push @$open_sock, $data; 212 | INFO("Found open socket '$1:$2/tcp' with pid '$3' at $server"); 213 | } 214 | # tcp 0 0 0.0.0.0:2222 0.0.0.0:* LISTEN - 215 | elsif ($line =~ m{^tcp\s+\d+\s+\d+\s+(\d+\.\d+\.\d+\.\d+):(\d+).+(LISTEN)\s+-}) { 216 | my $data = { proto => 'tcp', addr => $1, port => $2, state => $3 }; 217 | my $open_sock = $map->{open_sock} ||= []; 218 | push @$open_sock, $data; 219 | INFO("Found open socket '$1:$2/tcp' without pid at $server"); 220 | } 221 | # tcp 0 0 213.13.146.24:5222 85.240.82.208:1048 ESTABLISHED31858/beam.smp 222 | elsif ($line =~ m{^(\S+)\s+\d+\s+\d+\s+(\d+\.\d+\.\d+\.\d+):(\d+)\s+(\d+\.\d+\.\d+\.\d+):(\d+)\s+(ESTABLISHED)\s*(\d+)/(.+)}) { 223 | my $data = { proto => $1, l_addr => $2, l_port => $3, r_addr => $4, r_port => $5, state => $6, pid => $7, short_name => $8 }; 224 | my $conns = $map->{conns} ||= []; 225 | push @$conns, $data; 226 | INFO("Found connection '$2:$3/$1' - '$4:$5/$1' with pid '$6' at $server"); 227 | } 228 | # tcp 0 0 10.135.33.30:50605 10.135.33.14:3306 ESTABLISHED- 229 | elsif ($line =~ m{^(\S+)\s+\d+\s+\d+\s+(\d+\.\d+\.\d+\.\d+):(\d+)\s+(\d+\.\d+\.\d+\.\d+):(\d+)\s+(ESTABLISHED)\s*-}) { 230 | my $data = { proto => $1, l_addr => $2, l_port => $3, r_addr => $4, r_port => $5, state => $6 }; 231 | my $conns = $map->{conns} ||= []; 232 | push @$conns, $data; 233 | INFO("Found connection '$2:$3/$1' - '$4:$5/$1' with at $server"); 234 | } 235 | # udp 0 0 0.0.0.0:32768 0.0.0.0:* 3430/rpc.statd 236 | elsif ($line =~ m{^udp\s+\d+\s+\d+\s+(\d+\.\d+\.\d+\.\d+):(\d+).+(\d+)/(.+)}) { 237 | my $data = { proto => 'udp', addr => $1, port => $2, pid => $3, short_name => $4, state => 'LISTEN' }; 238 | my $open_sock = $map->{open_sock} ||= []; 239 | push @$open_sock, $data; 240 | INFO("Found open socket '$1:$2/udp' with pid '$3' at $server"); 241 | } 242 | # udp 0 0 0.0.0.0:32768 0.0.0.0:* - 243 | elsif ($line =~ m{^udp\s+\d+\s+\d+\s+(\d+\.\d+\.\d+\.\d+):(\d+).+-}) { 244 | my $data = { proto => 'udp', addr => $1, port => $2, state => 'LISTEN' }; 245 | my $open_sock = $map->{open_sock} ||= []; 246 | push @$open_sock, $data; 247 | INFO("Found open socket '$1:$2/udp' at $server"); 248 | } 249 | elsif ($line =~ /^tcp6\s/) { 250 | return; 251 | } 252 | elsif ($line =~ /^unix\s/) { 253 | return; 254 | } 255 | elsif ($line =~ /\s+FIN_WAIT1\s+-/) { 256 | return; 257 | } 258 | elsif ($line =~ /\s+(?:FIN_WAIT1|TIME_WAIT|LAST_ACK|SYN_SENT|CLOSING|CLOSE_WAIT)/) { 259 | return; 260 | } 261 | else { 262 | WARN('Unparsed netstat line: ', $line); 263 | } 264 | } 265 | 266 | ################################### 267 | # Iterate over a file descriptor, l 268 | 269 | sub foreach_line { 270 | my ($cb) = @_; 271 | 272 | my %context; 273 | 274 | # open(my $fh, '<', $file) || croak('Could not open file: $file'); 275 | 276 | while (my $line = <>) { 277 | chomp($line); 278 | # eval { $cb->($line, \%context) }; 279 | $cb->($line, \%context); 280 | if ($@) { 281 | print STDERR "ERROR: $@"; 282 | return undef; 283 | } 284 | } 285 | 286 | return \%context; 287 | } 288 | 289 | sub walk { 290 | my ($root, $action, @rest) = @_; 291 | 292 | $action->($root, @rest); 293 | 294 | return if !ref($root); 295 | if (UNIVERSAL::isa($root => 'ARRAY')) { 296 | my $i = 0; 297 | walk($_, $action, @rest, $i++) for @$root; 298 | } 299 | elsif (UNIVERSAL::isa($root => 'HASH')) { 300 | walk($root->{$_}, $action, @rest, $_) for keys %$root; 301 | } 302 | } -------------------------------------------------------------------------------- /bin/x-markdown-preview: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Markdown preview of stdin 4 | 5 | file=/tmp/markdown_preview.$$.html 6 | 7 | Markdown.pl $1 | x-html-use-my-css > $file 8 | open $file 9 | ( sleep 5 && rm -f $file ) & 10 | -------------------------------------------------------------------------------- /bin/x-mime-exploder: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use: 5.14; 4 | use MIME::Parser; 5 | 6 | my ($mesg) = @ARGV; 7 | 8 | die "Usage: x-mime-expload message.mbox\n" unless defined $mesg; 9 | die "FATAL: cannot read $mesg\n" unless -r $mesg; 10 | 11 | my $parser = MIME::Parser->new; 12 | $parser->output_under('.'); 13 | $parser->output_prefix('mime-exploder'); 14 | $parser->extract_uuencode(1); 15 | $parser->ignore_errors(0); 16 | 17 | my $entity; 18 | eval { $entity = $parser->parse_open($mesg) }; 19 | die "FATAL: $@ - ".$parser->last_error."\n" if $@; 20 | -------------------------------------------------------------------------------- /bin/x-music-what-who: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # hat tip to @consttype: https://twitter.com/#!/consttype/status/211035411026427904 4 | 5 | osascript -e 'tell application "iTunes" to pause' 6 | 7 | x='tell application "iTunes" to get' 8 | y='of current track as string' 9 | say Title is `osascript -e "$x name $y"` . Author is `osascript -e "$x artist $y"` 10 | 11 | osascript -e 'tell application "iTunes" to play' 12 | -------------------------------------------------------------------------------- /bin/x-mysql-check-tables: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Check all MySQL tables 4 | # 5 | 6 | use strict; 7 | use warnings; 8 | use Getopt::Long; 9 | use DBI; 10 | 11 | my $host; 12 | my $user; 13 | my $pwd = $ENV{MYSQL_PASSWORD}; 14 | my $askpass; 15 | my $count; 16 | my $skip_empty; 17 | 18 | my $ok = GetOptions( 19 | "host=s", \$host, 20 | "user=s", \$user, 21 | "password=s", \$pwd, 22 | "askpass", \$askpass, 23 | "count", \$count, 24 | "skip-empty", \$skip_empty, 25 | ); 26 | 27 | usage() if !$ok; 28 | 29 | my $db = shift @ARGV; 30 | 31 | my $dsn = 'dbi:mysql:'; 32 | $dsn .= "host=$host;" if $host; 33 | $dsn .= "database=$db;" if $db; 34 | 35 | $pwd = prompt_noecho("Enter password:") if $askpass; 36 | 37 | my $dbh = DBI->connect($dsn, $user, $pwd) || 38 | die $DBI::errstr; 39 | 40 | $count = 1 if $skip_empty; 41 | 42 | if ($db) { check_tables($dbh, $db) } 43 | else { list_dbs($dbh) } 44 | 45 | ############## 46 | # Check tables 47 | 48 | sub check_tables { 49 | my ($dbh, $db) = @_; 50 | 51 | my $tables = $dbh->selectcol_arrayref(q{ 52 | SHOW TABLES 53 | }); 54 | 55 | if (!@$tables) { 56 | print "No tables found in database $db\n"; 57 | return; 58 | } 59 | 60 | print "Found ".@$tables." tables in db $db:\n"; 61 | foreach my $table (sort @$tables) { 62 | check_table($dbh, $table); 63 | } 64 | print "\n"; 65 | 66 | return; 67 | } 68 | 69 | sub check_table { 70 | my ($dbh, $table) = @_; 71 | 72 | my $result = $dbh->selectall_arrayref( 73 | qq{ CHECK TABLE $table }, 74 | { Slice => {} }, 75 | ); 76 | my $rows; 77 | ($rows) = $dbh->selectrow_array(qq{ SELECT COUNT(*) FROM $table }) 78 | if $count; 79 | 80 | return if $skip_empty && $rows == 0; 81 | 82 | if (@$result == 1 && is_ok($result->[0])) { 83 | print " $table".(defined $rows? "( $rows )" : '').": is OK\n"; 84 | return; 85 | } 86 | 87 | print "\n $table".(defined $rows? "($rows)" : '').":\n"; 88 | foreach my $row (@$result) { 89 | print " $row->{Op}: $row->{Msg_type} => '$row->{Msg_text}'\n"; 90 | print " ** Table is OK **\n" if is_ok($row); 91 | } 92 | print "\n\n"; 93 | 94 | return; 95 | } 96 | 97 | sub is_ok { 98 | my ($report) = @_; 99 | 100 | return 1 101 | if $report->{Msg_type} eq 'status' 102 | && $report->{Msg_text} eq 'OK'; 103 | 104 | return 0; 105 | } 106 | 107 | 108 | ########## 109 | # List DBs 110 | 111 | sub list_dbs { 112 | my ($dbh) = @_; 113 | 114 | my $dbs = $dbh->selectcol_arrayref(q{ 115 | SHOW DATABASES 116 | }); 117 | 118 | if (!@$dbs) { 119 | print "No databases found\n"; 120 | return; 121 | } 122 | 123 | print "Found ".@$dbs." databases:\n"; 124 | foreach my $db (@$dbs) { 125 | print " $db\n"; 126 | } 127 | print "\n"; 128 | 129 | return; 130 | } 131 | 132 | 133 | ####### 134 | # Utils 135 | 136 | # Stolen from maatkit 137 | sub prompt_noecho { 138 | my ( $prompt ) = @_; 139 | local $| = 1; 140 | 141 | print $prompt 142 | or die "Cannot print: $!"; 143 | 144 | my $response; 145 | eval { 146 | require Term::ReadKey; 147 | Term::ReadKey::ReadMode('noecho'); 148 | chomp($response = ); 149 | Term::ReadKey::ReadMode('normal'); 150 | print "\n" 151 | or die "Cannot print: $!"; 152 | }; 153 | if ( $@ ) { 154 | die "Cannot read response; is Term::ReadKey installed? $@"; 155 | } 156 | 157 | return $response; 158 | } 159 | 160 | 161 | -------------------------------------------------------------------------------- /bin/x-mysql-table-report: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | SQL="SELECT count(*) TABLES, 4 | concat(round(sum(table_rows)/1000000,2),'M') rows, 5 | concat(round(sum(data_length)/(1024*1024*1024),2),'G') DATA, 6 | concat(round(sum(index_length)/(1024*1024*1024),2),'G') idx, 7 | concat(round(sum(data_length+index_length)/(1024*1024*1024),2),'G') total_size, 8 | round(sum(index_length)/sum(data_length),2) idxfrac 9 | FROM information_schema.TABLES; 10 | " 11 | 12 | echo $SQL | mysql $@ 13 | 14 | SQL="SELECT count(*) TABLES, 15 | table_schema, 16 | concat(round(sum(table_rows)/1000000,2),'M') rows, 17 | concat(round(sum(data_length)/(1024*1024*1024),2),'G') DATA, 18 | concat(round(sum(index_length)/(1024*1024*1024),2),'G') idx, 19 | concat(round(sum(data_length+index_length)/(1024*1024*1024),2),'G') total_size, 20 | round(sum(index_length)/sum(data_length),2) idxfrac 21 | FROM information_schema.TABLES 22 | GROUP BY table_schema 23 | ORDER BY sum(data_length+index_length) DESC 24 | LIMIT 10; 25 | " 26 | 27 | echo 28 | echo $SQL | mysql $@ 29 | -------------------------------------------------------------------------------- /bin/x-net-my-external-ip: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Use UPnP to find out your own IP address if behind a NAT device 4 | # 5 | # Pedro Melo 6 | # 7 | 8 | use strict; 9 | use warnings; 10 | use Net::UPnP::ControlPoint; 11 | use Net::UPnP::GW::Gateway; 12 | 13 | my $obj = Net::UPnP::ControlPoint->new(); 14 | my @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); 15 | my $devNum= 0; 16 | 17 | foreach my $dev (@dev_list) { 18 | my $device_type = $dev->getdevicetype(); 19 | print " >> device type $device_type\n"; 20 | next unless $device_type eq 'urn:schemas-upnp-org:device:InternetGatewayDevice:1'; 21 | 22 | my $name = $dev->getfriendlyname() || ''; 23 | print " >> name $name\n"; 24 | 25 | next unless $dev->getservicebyname('urn:schemas-upnp-org:service:WANIPConnection:1'); 26 | 27 | my $gwdev = Net::UPnP::GW::Gateway->new; 28 | $gwdev->setdevice($dev); 29 | 30 | print "\tExternalIPAddress = " . $gwdev->getexternalipaddress() . "\n"; 31 | 32 | print "[$devNum]: $name\n"; 33 | next unless $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); 34 | 35 | my $condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); 36 | next unless defined($condir_service); 37 | 38 | my %action_in_arg = ( 39 | 'ObjectID' => 0, 40 | 'BrowseFlag' => 'BrowseDirectChildren', 41 | 'Filter' => '*', 42 | 'StartingIndex' => 0, 43 | 'RequestedCount' => 0, 44 | 'SortCriteria' => '', 45 | ); 46 | my $action_res = $condir_service->postcontrol('Browse', \%action_in_arg); 47 | next unless $action_res->getstatuscode() == 200; 48 | 49 | my $actrion_out_arg = $action_res->getargumentlist(); 50 | next unless $actrion_out_arg->{'Result'}; 51 | 52 | my $result = $actrion_out_arg->{'Result'}; 53 | while ($result =~ m/(.*?)<\/dc:title>/sgi) { 54 | print "\t$1\n"; 55 | } 56 | $devNum++; 57 | } 58 | -------------------------------------------------------------------------------- /bin/x-net-my-ip-address: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec curl ifconfig.co 4 | -------------------------------------------------------------------------------- /bin/x-net-upnp-browser: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Scan the Network for UPnP devices 4 | # 5 | # Pedro Melo 6 | # 7 | 8 | use strict; 9 | use warnings; 10 | use Net::UPnP::ControlPoint; 11 | 12 | # $Net::UPnP::DEBUG++; 13 | 14 | my $obj = Net::UPnP::ControlPoint->new(); 15 | my @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); 16 | my $devNum= 0; 17 | 18 | foreach my $dev (@dev_list) { 19 | my $device_type = $dev->getdevicetype(); 20 | my $name = $dev->getfriendlyname(); 21 | if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { 22 | $name ||= ''; 23 | print "Device type '$device_type' named '$name', ignored\n"; 24 | next; 25 | } 26 | 27 | print "[$devNum]: $name\n"; 28 | next unless $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); 29 | 30 | my $condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); 31 | next unless defined($condir_service); 32 | 33 | my %action_in_arg = ( 34 | 'ObjectID' => 0, 35 | 'BrowseFlag' => 'BrowseDirectChildren', 36 | 'Filter' => '*', 37 | 'StartingIndex' => 0, 38 | 'RequestedCount' => 0, 39 | 'SortCriteria' => '', 40 | ); 41 | my $action_res = $condir_service->postcontrol('Browse', \%action_in_arg); 42 | next unless $action_res->getstatuscode() == 200; 43 | 44 | my $actrion_out_arg = $action_res->getargumentlist(); 45 | next unless $actrion_out_arg->{'Result'}; 46 | 47 | my $result = $actrion_out_arg->{'Result'}; 48 | while ($result =~ m/(.*?)<\/dc:title>/sgi) { 49 | print "\t$1\n"; 50 | } 51 | $devNum++; 52 | } 53 | -------------------------------------------------------------------------------- /bin/x-notify: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Runs script, and prints a notification with growl 4 | # or libnotify when it finishes 5 | # 6 | # Written sometime in 2006, posted 2007/08 7 | # Part of Susie since May 2008. 8 | # 9 | # With Tips from Ranger Rick, Tim Bunce and Ruben Fonseca 10 | # 11 | # Pedro Melo 12 | # 13 | 14 | if [ -z "$1" ] ; then 15 | cat < /dev/null 38 | has_notifo=$? 39 | env growlnotify -h > /dev/null 2> /dev/null 40 | has_growl=$? 41 | env notify-send -? > /dev/null 2> /dev/null 42 | has_libnotify=$? 43 | 44 | # notify the user, growl or libnotify 45 | if [ "$has_notifo" == 0 ] ; then 46 | notifo --label x-notify -- "Script completed ($result): $@" 47 | elif [ "$has_growl" == "0" ] ; then 48 | growlnotify -m "Script '$@' $result" -s "Background script notification" & 49 | elif [ "$has_libnotify" == "0" ] ; then 50 | notify-send "Script '$@' $result" "Background script notification" & 51 | else 52 | echo no notitifer... 53 | fi 54 | 55 | 56 | # exit with the original status 57 | exit $status 58 | -------------------------------------------------------------------------------- /bin/x-password-char-table: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Generates a table of characters for secure passwords 4 | # 5 | # Author: John Graham-Cumming (http://blog.jgc.org/) 6 | # Orignal URL: http://blog.jgc.org/2010/12/my-password-generator-code.html 7 | # Explanation: http://blog.jgc.org/2010/12/write-your-passwords-down.html 8 | # 9 | # *** dep Math::Pari fails to compile on Mac OS X *** 10 | # 11 | 12 | use strict; 13 | use warnings; 14 | 15 | use Crypt::Random qw(makerandom_itv); 16 | use HTML::Entities; 17 | 18 | print "
\n  ";
19 | print join(' ', ('A' .. 'Z'));
20 | print "\n +-", '--' x 25, "\n";
21 | 
22 | foreach my $x ('A' .. 'Z') {
23 |   print "$x|";
24 |   foreach my $y (0 .. 25) {
25 |     print encode_entities(
26 |       chr(
27 |         makerandom_itv(
28 |           Strength => 1,
29 |           Uniform  => 1,
30 |           Lower => ord('!'),
31 |           Upper => ord('~')
32 |         )
33 |       )
34 |     ), ' ';
35 |   }
36 |   print "\n";
37 | }
38 | print '
'; 39 | -------------------------------------------------------------------------------- /bin/x-pdf-stack: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use PDF::API2; 6 | 7 | my $destination = shift @ARGV; 8 | usage("Requires a destination file name") unless $destination; 9 | usage("Requires at least two PDF files") if @ARGV < 2; 10 | 11 | my $top = PDF::API2->open(shift @ARGV); 12 | my $page = $top->openpage(1); 13 | while (@ARGV) { 14 | my $next = PDF::API2->open(shift @ARGV); 15 | $top->importpage($next, 1, $page); 16 | } 17 | $top->saveas($destination); 18 | $top->end; 19 | -------------------------------------------------------------------------------- /bin/x-perl-bench: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Quick Perl benchmark 4 | # 5 | # TODO: write benchmark script as my_bench.pl on cwd 6 | # 7 | # Pedro Melo November 2011 8 | # 9 | 10 | use strict; 11 | use warnings; 12 | use Benchmark 'cmpthese'; 13 | 14 | sub out; 15 | sub abort; 16 | 17 | my $filename; 18 | $filename = shift(@ARGV) if @ARGV; 19 | 20 | out "Type the Perl code for the versions you want to benchmark"; 21 | out "Benchmark script will be written as '$filename'" if $filename; 22 | 23 | my @versions; 24 | while (my $version = read_version()) { 25 | my $script = 'sub {' . $version->{script} . '}'; 26 | my $sub = eval $script; 27 | if ($@) { 28 | out "Error evaluating your script: $@"; 29 | out "We will ignore this script, try again."; 30 | next; 31 | } 32 | $version->{sub} = $sub; 33 | push @versions, $version; 34 | } 35 | abort "We need at least one version to benchmark..." unless @versions; 36 | 37 | if ($filename) { 38 | open(my $fh, '>', $filename) 39 | or abort "Could not open '$filename' for writting: $!"; 40 | print $fh 41 | "#!perl\n\nuse strict;\nuse warnings;\nuse Benchmark 'cmpthese';\n\n"; 42 | 43 | my $i = 0; 44 | foreach my $v (@versions) { 45 | $i++; 46 | print $fh "my \$version_$i = sub {\n$v->{script}};\n\n"; 47 | } 48 | 49 | print $fh "\nprint \"Starting the benchmark...\\n\";\n\ncmpthese(0, {"; 50 | 51 | $i = 0; 52 | foreach my $v (@versions) { 53 | $i++; 54 | print $fh " '$v->{name}' => \$version_$i,\n"; 55 | } 56 | print $fh "});\n\n"; 57 | close($fh); 58 | 59 | out "Script '$filename' generated"; 60 | } 61 | else { 62 | out "Starting the benchmark (this may take a while)..."; 63 | cmpthese(0, {map { ($_->{name} => $_->{sub}) } @versions}); 64 | } 65 | 66 | 67 | ########### 68 | # Utilities 69 | 70 | sub out { 71 | return unless -t \*STDOUT; 72 | print @_, "\n"; 73 | } 74 | 75 | sub abort { 76 | out @_; 77 | exit(1); 78 | } 79 | 80 | sub read_version { 81 | out 82 | "Define the name for this version. Type . (dot) if no more versions are required."; 83 | my $name = read_non_empty_line(); 84 | return if $name eq '.'; 85 | 86 | out "Write the code for '$name',\nend with a . (dot) on a single line."; 87 | my $script = read_script(); 88 | 89 | return {name => $name, script => $script}; 90 | } 91 | 92 | sub read_non_empty_line { 93 | while (<>) { 94 | chomp; 95 | s/^\s+|\s+$//g; 96 | return $_ if $_; 97 | } 98 | abort "Aborted..."; 99 | } 100 | 101 | sub read_script { 102 | my $script = ''; 103 | while (<>) { 104 | chomp; 105 | last if $_ eq '.'; 106 | $script .= $_ . "\n"; 107 | } 108 | 109 | return $script; 110 | } 111 | -------------------------------------------------------------------------------- /bin/x-perl-benchmark-xml-parsers: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | package SAXY; 4 | 5 | use XML::LibXML; 6 | use XML::SAX::Base; 7 | use base qw(XML::SAX::Base); 8 | 9 | package main; 10 | 11 | use strict; 12 | use warnings; 13 | use XML::LibXML; 14 | use XML::Parser; 15 | use Benchmark qw( cmpthese ); 16 | 17 | my $libxml = XML::LibXML->new(); 18 | 19 | my $sax_handler = SAXY->new; 20 | my $libxml_sax = XML::LibXML->new(Handler => $sax_handler); 21 | 22 | my $expat = XML::Parser->new( 23 | Handlers => { 24 | Start => sub {}, 25 | End => sub {}, 26 | Char => sub {}, 27 | }, 28 | ); 29 | 30 | my $expat_no_hand = XML::Parser->new( 31 | Handlers => { 32 | }, 33 | ); 34 | 35 | my $expat_tree = XML::Parser->new( Style => 'Tree' ); 36 | 37 | my $stanza = q{ 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | }; 59 | 60 | 61 | my $count = $ENV{COUNT} || 1000; 62 | 63 | cmpthese($count, { 64 | 'LibXML' => sub { 65 | $libxml->parse_string($stanza); 66 | }, 67 | 'LibXML SAX' => sub { 68 | $libxml_sax->parse_string($stanza); 69 | }, 70 | 'Expat (Tree)' => sub { 71 | $expat_tree->parse($stanza); 72 | }, 73 | 'Expat (SAX with handlers)' => sub { 74 | $expat->parse($stanza); 75 | }, 76 | 'Expat (SAX, no handlers)' => sub { 77 | $expat_no_hand->parse($stanza); 78 | }, 79 | }); 80 | -------------------------------------------------------------------------------- /bin/x-perl-c3-visualize: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | =pod 7 | 8 | This is a visualization tool to help with 9 | understanding large MI hierarchies. It will 10 | output a DOT file for rendering with Graphviz. 11 | 12 | NOTE: 13 | This program is currently very primative, and 14 | may break under some circumstances. If you 15 | encounter one of those circumstances, please 16 | email me about it so that I can improve this 17 | tool. 18 | 19 | GRAPH LEGEND: 20 | In the graphs the green arrows are the ISA, 21 | and the red arrows are the C3 dispatch order. 22 | 23 | =cut 24 | 25 | use Class::C3 (); 26 | 27 | @ARGV || die "usage : visualize_c3.pl | "; 28 | 29 | my ($class, $OUT); 30 | if (scalar @ARGV == 1) { 31 | $class = shift @ARGV; 32 | eval "use $class"; 33 | die "Could not load '$class' :\n$@" if $@; 34 | } 35 | else { 36 | my $file = shift @ARGV; 37 | $class = shift @ARGV; 38 | $OUT = shift @ARGV; 39 | do $file; 40 | die "Could not load '$file' :\n$@" if $@; 41 | } 42 | 43 | Class::C3->initialize(); 44 | 45 | my @MRO = Class::C3::calculateMRO($class); 46 | 47 | sub get_class_str { 48 | my $class = shift; 49 | (join "_" => (split '::' => $class)); 50 | } 51 | 52 | my $output = "graph test {\n"; 53 | 54 | my $prev; 55 | foreach my $class (@MRO) { 56 | my $class_str = get_class_str($class); 57 | $output .= "node_${class_str} [ label = \"" . $class . "\" ];\n"; 58 | { 59 | no strict 'refs'; 60 | foreach my $super (@{"${class}::ISA"}) { 61 | $output .= "node_" . get_class_str($super) . 62 | " -- node_${class_str}" . 63 | " [ dir = back, color = green ];\n"; 64 | } 65 | } 66 | if ($prev) { 67 | $output .= "node_${class_str} -- node_${prev} [ dir = back, color = red ];\n"; 68 | } 69 | $prev = $class_str; 70 | } 71 | 72 | $output .= "}\n"; 73 | 74 | warn $output; 75 | 76 | if ($OUT) { 77 | open OUT, ">", $OUT || die "could not open '$OUT' for output"; 78 | print OUT $output; 79 | close OUT; 80 | } 81 | else { 82 | print $output; 83 | } 84 | -------------------------------------------------------------------------------- /bin/x-perl-check-config: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Check configuration files with Config::Any 4 | # 5 | 6 | use strict; 7 | use warnings; 8 | use Config::Any; 9 | use Data::Dump qw( pp ); 10 | use Getopt::Long; 11 | 12 | my $opt_json; 13 | GetOptions('json' => \$opt_json) || usage(); 14 | 15 | if ($opt_json) { 16 | eval { require JSON }; 17 | fatal("option --json requires the JSON module from CPAN") if $@; 18 | } 19 | 20 | usage('Missing required configuration file to parse') unless @ARGV; 21 | 22 | my $cfg = Config::Any->load_files({files => \@ARGV, use_ext => 1}); 23 | 24 | for my $c (@$cfg) { 25 | while (my ($filename, $config) = each %$c) { 26 | print ">>> Got configuration from file '$filename':\n"; 27 | 28 | if ($opt_json) { print JSON::to_json($config) } 29 | else { print pp($config) } 30 | 31 | print "\n"; 32 | } 33 | } 34 | 35 | 36 | ############# 37 | 38 | sub fatal { 39 | my $mesg = join('', @_); 40 | 41 | print "FATAL: $mesg\n" if $mesg; 42 | exit(1); 43 | } 44 | 45 | sub usage { 46 | print <<" EOU"; 47 | 48 | Usage: x-perl-check-config [--json] config_file* 49 | 50 | Parses 1 or more configuration files (JSON, .ini, YAML supported) 51 | and dumps the internal perl structure or as JSON if the '--json' 52 | option is used. 53 | 54 | EOU 55 | 56 | fatal(@_); 57 | } 58 | -------------------------------------------------------------------------------- /bin/x-perl-completions: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # A huge number of completion strings for Perl programming 4 | # 5 | # To activate on TextMate, open Bundle Editor, add a new preference item with this text: 6 | # 7 | # { completionCommand = 'x-perl-completions -f "$TM_SELECTED_FILE" "$TM_CURRENT_WORD"'; } 8 | # 9 | # and make sure the Scope Selector is source.perl 10 | # 11 | # Pedro Melo, 2012 12 | # License: Artistic v2 13 | # 14 | 15 | use strict; 16 | use warnings; 17 | use Getopt::Long; 18 | use Path::Class 'dir'; 19 | 20 | sub usage { die "Usage: x-textmate-perl-completions [-f filename] word_to_complete\n" } 21 | my ($word, $file, $debug); 22 | GetOptions('file=s' => \$file, 'debug=s' => \$debug) 23 | or usage(); 24 | $word = shift @ARGV; 25 | usage() unless $word; 26 | 27 | 28 | my $source; 29 | $source = do { local $/; my $fh; open($fh, '<', $file) && <$fh> } if $file; 30 | 31 | my @completions; 32 | my @modules; 33 | 34 | ## Global completions 35 | push @completions, '#!perl', '#!/usr/bin/env perl'; 36 | push @completions, qw( 37 | new 38 | chomp chop chr crypt hex index lc lcfirst length oct ord pack reverse 39 | rindex sprintf substr tr uc ucfirst 40 | pos quotemeta split study qr 41 | abs atan2 cos exp hex int log oct rand sin sqrt srand 42 | each keys pop push shift splice unshift values 43 | grep join map reverse sort unpack 44 | delete each exists keys values 45 | binmode close closedir die eof fileno flock format 46 | getc print printf read readdir rewinddir say seek seekdir select 47 | syscall sysread sysseek syswrite tell telldir truncate warn write 48 | pack read syscall sysread syswrite unpack vec 49 | chdir chmod chown chroot fcntl glob ioctl link lstat mkdir open opendir 50 | readlink rename rmdir stat symlink sysopen umask unlink utime 51 | caller continue die do dump eval exit goto last next redo return sub 52 | wantarray 53 | break continue default given when 54 | caller import local my our package state use 55 | defined dump eval formline local my our reset scalar state undef wantarray 56 | alarm exec fork getpgrp getppid getpriority kill pipe setpgrp setpriority 57 | sleep system times wait waitpid 58 | do import no package require use 59 | bless dbmclose dbmopen package ref tie tied untie use 60 | accept bind connect getpeername getsockname getsockopt listen recv send 61 | setsockopt shutdown socket socketpair 62 | msgctl msgget msgrcv msgsnd semctl semget semop shmctl shmget shmread 63 | shmwrite 64 | endgrent endhostent endnetent endpwent getgrent getgrgid getgrnam getlogin 65 | getpwent getpwnam getpwuid setgrent setpwent 66 | endprotoent endservent gethostbyaddr gethostbyname gethostent getnetbyaddr 67 | getnetbyname getnetent getprotobyname getprotobynumber getprotoent 68 | getservbyname getservbyport getservent sethostent setnetent setprotoent 69 | setservent 70 | gmtime localtime time times 71 | abs bless break chomp chr continue default exists formline given glob 72 | import lc lcfirst lock map my no our prototype readline readpipe ref 73 | sub sysopen tie tied uc ucfirst untie use when 74 | __PACKAGE__ __END__ __FILE__ __LINE__ __DATA__ 75 | BEGIN INIT CHECK END 76 | ISA VERSION 77 | ); 78 | push @completions, map {"=$_"} qw( encoding head1 head2 head3 head4 over item back for ); 79 | 80 | push @modules, qw( 81 | 5.014 strict warnings lib base parent utf8 82 | Moo Moo::Role 83 | Moose Moose::Role 84 | namespace::autoclean 85 | DateTime DateTime::Format::MySQL 86 | Carp 87 | Time::HiRes 88 | Try::Tiny 89 | Sub::Name 90 | Data::Dump 91 | Scalar::Util 92 | JSON JSON::XS 93 | AnyEvent 94 | ZeroMQ 95 | Encode 96 | Data::UUID Data::UUID::LibUUID 97 | Exporter 98 | ); 99 | push @modules, 'namespace::clean', "namespace::clean -except => 'meta'"; 100 | 101 | ## Test modules 102 | if ($file && $file =~ /[.]t$/) { 103 | push @modules, qw( Test::More Test::Deep Test::Fatal Test::LongString ); 104 | 105 | push @completions, qw( 106 | ok is isnt like unlike can_ok isa_ok new_ok pass fail done_testing 107 | subtest diag note explain SKIP TODO todo_skip BAIL_OUT 108 | 109 | cmp_deeply cmp_bag cmp_set cmp_methods eq_deeply cmp_details 110 | ignore methods listmethods shallow noclass useclass re 111 | superhashof subhashof bag set superbagof all any isa array_each 112 | str num bool code deep_diag 113 | 114 | exception 115 | 116 | like_string 117 | ); 118 | push @completions, 'done_testing();'; 119 | } 120 | 121 | 122 | ## Make Moo/Moose/Scalar::Util/Carp and others stuff available, always 123 | push @completions, qw( 124 | extends with 125 | has 126 | before around after 127 | BUILD BUILDARGS DEMOLISH 128 | does 129 | quote_sub 130 | is isa default weak_ref init_arg builder clearer ro rw rwp lazy 131 | blessed 132 | carp croak confess longmess 133 | encode_json decode_json 134 | encode decode 135 | try catch finally 136 | gettimeofday tv_interval usleep 137 | method func 138 | EXPORT EXPORT_OK EXPORT_TAGS 139 | ); 140 | ## Some of my favorites 141 | push @completions, 142 | 'clearer => 1,', 143 | "is => 'lazy',", 144 | "is => 'ro',", 145 | "is => 'rwp',", 146 | "is => 'rw',", 147 | "default => sub {},", 148 | "weak_ref => 1,", 149 | ; 150 | 151 | 152 | ## Add package names for current module 153 | push @modules, $source =~ m/^\s*package\s+(\S+)/gm if $source; 154 | if ($file && $file =~ /[.]pm$/) { 155 | my ($module) = $file =~ m!/t?lib/(.+)[.]pm$!; 156 | 157 | $module =~ s/\//::/g; 158 | push @modules, $module; 159 | } 160 | 161 | 162 | ## Add nearby packages 163 | if ($file && $file =~ /[.](pm|t)$/) { 164 | my ($root) = $file =~ m!^(.+)/(t|lib)/.+[.](pm|t)$!; 165 | 166 | $root = dir($root); 167 | for my $lib ($root->subdir('lib'), $root->subdir('t', 'tlib')) { 168 | next unless -d "$lib"; 169 | $lib->recurse( 170 | callback => sub { 171 | my ($f) = @_; 172 | return if $f->is_dir; 173 | return unless $f->basename =~ /[.]pm$/; 174 | 175 | my $fn = $f->relative($lib)->stringify; 176 | $fn =~ s/[.]pm$//; 177 | $fn =~ s/\//::/g; 178 | push @completions, $fn; 179 | } 180 | ); 181 | } 182 | } 183 | 184 | 185 | ## Add modules, smartly 186 | push @completions, @modules; 187 | push @completions, map {"use $_"} @modules; 188 | 189 | 190 | ## Filter completions 191 | my %seen; 192 | my @matched = grep { !$seen{$_}++ } grep {/^$word/} @completions; 193 | 194 | if ($debug) { 195 | open(my $fh, '>', $debug); 196 | print $fh "List of all words collected:\n"; 197 | print $fh map {"\t$_\n"} @completions; 198 | print $fh "\nMList of matched completions with word '$word':\n"; 199 | print $fh map {"\t$_\n"} @matched; 200 | close($fh); 201 | } 202 | 203 | print map {"$_\n"} @matched; 204 | -------------------------------------------------------------------------------- /bin/x-perl-confess-env: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Make sure all croaks will confess 4 | # 5 | # Pedro Melo , 2008/05/30 6 | # 7 | 8 | MYPERL5OPT="-MCarp=verbose" 9 | if [ -z "$PERL5OPT" ] ; then 10 | PERL5OPT=$MYPERL5OPT 11 | else 12 | PERL5OPT="$PERL5OPT $MYPERL5OPT" 13 | fi 14 | export PERL5OPT 15 | 16 | $@ 17 | -------------------------------------------------------------------------------- /bin/x-perl-cover-env: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Runs perl code with Devel::Cover enabled 4 | # 5 | # Optionaly recalculate the coverage report with -r 6 | # 7 | # Pedro Melo , 2008/05/30 8 | # 9 | 10 | if [ "$1" = '-r' ] ; then 11 | RECALC_COVERAGE=1 12 | shift 13 | fi 14 | 15 | # Run rest of command line in a subshell with coverage enabled 16 | ( 17 | MYPERL5OPT="-MDevel::Cover=+ignore,^local/,+ignore,^t/,+ignore,^xt/,+ignore,bin/prove" 18 | if [ -z "$PERL5OPT" ] ; then 19 | PERL5OPT=$MYPERL5OPT 20 | else 21 | PERL5OPT="$PERL5OPT $MYPERL5OPT" 22 | fi 23 | export PERL5OPT 24 | 25 | if [ -z "$1" ] ; then 26 | echo PERL5OPT=$PERL5OPT 27 | else 28 | $@ 29 | fi 30 | ) 31 | 32 | if [ "$RECALC_COVERAGE" = '1' ] ; then 33 | # test_for_covered=`covered` 34 | # if [ $? = 255 ] ; then 35 | # covered runs 36 | # fi 37 | cover -select_re ^lib/ -report Html_basic -annotation git 38 | open cover_db/coverage.html 39 | fi 40 | -------------------------------------------------------------------------------- /bin/x-perl-create-cpanfile-snapshot: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Cwd; 6 | use Getopt::Long; 7 | 8 | sub usage { 9 | print "Error: $@\n" if $@; 10 | 11 | print < [...] 13 | 14 | Use the current folder cpanfile to generate a fresh cpanfile.snapshot. 15 | 16 | Uses a volume to cache the installed modules, the follow-up runs will be much faster. 17 | 18 | If you need extra packages to install, just pass them along like this: 19 | 20 | x-perl-create-cpanfile-snapshot libidn-dev file-dev 21 | 22 | 23 | Options: 24 | 25 | --dryrun Do everything except run Docker 26 | --verbose Show what is going on 27 | --volume Define the name of the persistent volume to use. 28 | If none is used, we will construct a new name based 29 | on the current work directory 30 | --reset Remove volume before starting, forces full rebuild 31 | --shell After the install is configured, start a shell 32 | 33 | --all Install all deps, including non-prod 34 | 35 | --official Use official Perl image 36 | --alpine Use Alpine Perl image 37 | --target=label Use local Dockerfile with a specific target label 38 | EOU 39 | exit(1); 40 | } 41 | 42 | GetOptions( 43 | \my %cfg, 'help|?', 'volume', 'reset', 'shell', 'all', 44 | 'next', 'verbose', 'official', 'alpine', 'dryrun', 'target=s' 45 | ) or usage(); 46 | usage() if $cfg{help}; 47 | 48 | $cfg{verbose} = 1 if $cfg{dryrun}; 49 | 50 | my $target = $cfg{target} || _fetch_target_label(); 51 | l("target for image to use as dep: $target"); 52 | 53 | my $single = 0; 54 | $single++ if $cfg{official}; 55 | $single++ if $cfg{alpine}; 56 | $single++ if $target; 57 | 58 | usage("Cannot use --official, --alpine, and --target= together") if $single > 1; 59 | my $vrs = "perl"; 60 | $vrs = "alpine" if $cfg{alpine}; 61 | 62 | ## use the project dir as volume name as a fallback 63 | my $cwd = getcwd(); 64 | 65 | my $vol = $cfg{volume}; 66 | unless ($vol) { 67 | $vol = $cwd; 68 | $vol =~ s/^$ENV{HOME}//; 69 | $vol =~ s{^/}{}g; 70 | $vol =~ s{/}{-}g; 71 | $vol .= "-cpan-deps-for-$vrs"; 72 | } 73 | l("use '$vol' as volume name"); 74 | 75 | if ($cfg{reset}) { 76 | l("remove volume '$vol', forcing full rebuild"); 77 | system('docker', 'volume', 'rm', $vol) and die "Error: failed to remove volume '$vol', exit code $!"; 78 | } 79 | 80 | my $label = 'latest-build'; 81 | $label = 'next-build' if $cfg{next}; 82 | $label = "$vrs-$label"; 83 | 84 | my $shell = $cfg{shell} || ''; 85 | my $deps = join(' ', @ARGV); 86 | l("install deps: $deps"); 87 | 88 | my $all = $cfg{all} ? ' --all ' : ''; 89 | 90 | $deps .= _fetch_deps_from_cpanfile($vrs); 91 | 92 | my $script = " 93 | set -xe 94 | if [ -n '$deps' ] ; then 95 | if [ '$vrs' = 'perl' ] ; then 96 | apt update 97 | apt install -y $deps 98 | else 99 | apk --no-cache add $deps 100 | fi 101 | fi 102 | rm -rf /deps/local 103 | ln -s /cache-deps /deps/local 104 | cd /src 105 | pdi-build-deps --skip-snapshot --verbose $all 106 | cp /deps/cpanfile.snapshot /src 107 | if [ -n \"$shell\" ] ; then 108 | exec /bin/sh 109 | fi 110 | "; 111 | l("Prepare script to run: $script"); 112 | 113 | my $docker_tag = "melopt/perl-alt:$label"; 114 | l(".... initial tag $docker_tag (target is $target)"); 115 | if ($target) { 116 | $docker_tag = lc($vol); 117 | l(".... found target $target, new docker tag is $docker_tag"); 118 | system('docker', 'build', '--tag', $docker_tag, '--target', $target, '.'); 119 | } 120 | l(".... final tag $docker_tag"); 121 | exec('docker', 'run', '-it', '--rm', '-v', "$vol:/cache-deps", '-v', "$cwd:/src", $docker_tag, '/bin/sh', '-c', $script) 122 | unless $cfg{dryrun}; 123 | 124 | sub l { 125 | return unless $cfg{verbose}; 126 | print "* @_\n"; 127 | } 128 | 129 | sub _fetch_deps_from_cpanfile { 130 | my ($vrs) = @_; 131 | my $fn = 'cpanfile.cfg'; 132 | $fn = 'cpanfile' unless -r $fn; 133 | 134 | l("Scan '$fn' for $vrs deps"); 135 | open(my $fh, $fn) or return ''; 136 | 137 | my @deps; 138 | while (<$fh>) { 139 | push @deps, $1 if m/^#+\s+requires_package_$vrs\s+(.+)$/i; 140 | push @deps, $1 if m/^#+\s+requires_package\s+(.+)$/i; 141 | } 142 | 143 | return '' unless @deps; 144 | l('Found dependencies: ', @deps); 145 | return join(' ', @deps); 146 | } 147 | 148 | sub _fetch_target_label { 149 | my $fn = 'cpanfile.cfg'; 150 | $fn = 'cpanfile' unless -r $fn; 151 | 152 | l("Scan '$fn' for Dockerfile target label"); 153 | open(my $fh, $fn) or return ''; 154 | 155 | my $target; 156 | while (<$fh>) { 157 | $target = $1 if m/^\s*#*\s*target_label\s+(.+)$/i; 158 | } 159 | 160 | return '' unless $target; 161 | l("Found target lavel: $target"); 162 | return $target; 163 | } 164 | -------------------------------------------------------------------------------- /bin/x-perl-docker-this: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Runs the current folder inside a docker container 4 | # 5 | # We use a special image that keeps the local/ folder under .docker-perl- 6 | # local/, and the proper ENV to find it. 7 | # 8 | 9 | docker run -it --rm -v `pwd`:/app melopt/alpine-perl-interactive "$@" 10 | -------------------------------------------------------------------------------- /bin/x-perl-edit-installed-module: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | my @modules = @ARGV; 7 | usage(1) unless @modules; 8 | 9 | my $editor = $ENV{EDITOR}; 10 | usage(1, 'You must define the EDITOR environment') unless $editor; 11 | 12 | my @paths; 13 | for my $module (@modules) { 14 | my $module_dir = $module; 15 | $module_dir =~ s/::/\//g; 16 | my $module_file = $module_dir.'.pm'; 17 | 18 | foreach my $inc (@INC) { 19 | my $path = "$inc/$module_file"; 20 | push @paths, $path if -e $path; 21 | 22 | my $path_dir = "$inc/$module_dir"; 23 | push @paths, $path_dir if -d $path_dir; 24 | } 25 | } 26 | 27 | if (@paths) { 28 | exec($editor, @paths); 29 | die("Could not exec() '$editor': $!"); 30 | } 31 | 32 | print "Modules not found in \@INC:\n\n"; 33 | foreach my $module (@modules) { 34 | print " * $module\n"; 35 | } 36 | print "\n"; 37 | exit(0); 38 | 39 | 40 | sub usage { 41 | my ($exit_code, $mesg) = @_; 42 | 43 | print <<" EOU"; 44 | Usage: x-perl-edit-installed-module MODULE [MODULE]* 45 | 46 | Starts your \$EDITOR with the installed version of MODULE 47 | EOU 48 | 49 | print "FATAL: $mesg\n" if $mesg; 50 | 51 | exit($exit_code); 52 | } 53 | -------------------------------------------------------------------------------- /bin/x-perl-expand-signature: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Expand Method::Signatures declarations to the pure perl version 4 | # 5 | # A minor syntax error inside a method or a func is hard to debug. This 6 | # snippet accepts the method or func declaration on stdin and outputs 7 | # the corresponding perl to stdout. 8 | # 9 | # Pedro Melo (c) 2011 10 | # 11 | 12 | use strict; 13 | use warnings; 14 | 15 | my $decl = do { local $\; <> }; 16 | my ($name) = $decl =~ m/\s*(?:method|func)\s+(\S+?)?\s*\(/; 17 | $name = '' unless $name; 18 | 19 | my $script = <<"EOS"; 20 | use Method::Signatures; 21 | 22 | BEGIN { 23 | no warnings; 24 | *Method::Signatures::DEBUG = sub { 25 | my (\$code) = \@_; 26 | return unless \$code =~ s/^inject: //; 27 | 28 | print "sub $name { \$code"; 29 | } 30 | } 31 | 32 | $decl 33 | } 34 | EOS 35 | 36 | eval $script; 37 | -------------------------------------------------------------------------------- /bin/x-perl-expand-signature-pp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | 4 | #### RE's 5 | 6 | my $decl_re = qr/ 7 | ^ 8 | \s* 9 | (method|func) 10 | \s* 11 | ([\w_]+) 12 | \s* 13 | [(] 14 | (.+?) 15 | [)] 16 | \s* 17 | [{] 18 | $ 19 | /x; 20 | 21 | my $match_self_name = qr/ 22 | \s* 23 | \$ 24 | ([\w_]+) 25 | : 26 | \s* 27 | ,? 28 | \s* 29 | /x; 30 | 31 | my $match_pos_protos = qr/ 32 | \s* 33 | \$ 34 | ([\w_]+) 35 | \s* 36 | (\?)? 37 | \s* 38 | ,? 39 | \s* 40 | /x; 41 | 42 | my $match_named_protos = qr/ 43 | \s* 44 | : 45 | \$ 46 | ([\w_]+) 47 | \s* 48 | (?: 49 | = 50 | \s* 51 | ( 52 | (?: 53 | ["'] 54 | .*? 55 | ['"] 56 | ) 57 | | 58 | (?: 59 | [{\]] 60 | .*? 61 | [}\]] 62 | ) 63 | | 64 | (?: 65 | [^,]* 66 | ) 67 | ) 68 | \s* 69 | )? 70 | \s* 71 | ,? 72 | \s* 73 | /x; 74 | 75 | 76 | #### Code 77 | 78 | my $decl = do { local $\; <> }; 79 | my ($type, $name, $proto) = $decl =~ m/$decl_re/; 80 | my @perl = ("sub $name {"); 81 | 82 | if ($type eq 'method') { 83 | if ($proto =~ s/^$match_self_name//) { 84 | push @perl, " my \$$1 = shift;"; 85 | } 86 | else { 87 | push @perl, ' my $self = shift;'; 88 | } 89 | } 90 | 91 | ## collect fixed pos args 92 | my @fixed; 93 | while ($proto =~ s/^$match_pos_protos//) { 94 | 95 | } 96 | 97 | ## collect named args 98 | my @named; 99 | while ($proto =~ s/^$match_named_protos//) { 100 | push @named, { name => $1, default => $2}; 101 | } 102 | 103 | print "# $decl\n", join("\n", @perl), "\n"; 104 | use Data::Dump qw(pp); print "proto '$proto' = ", pp(\@named), "\n"; 105 | -------------------------------------------------------------------------------- /bin/x-perl-explain: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | my $input = do { local $/; <> }; 7 | 8 | show_cant_locate($1) if $input =~ /(Can't locate .+? in \@INC.+)/; 9 | 10 | 11 | sub show_cant_locate { 12 | my ($m) = @_; 13 | my ($pack, $inc, $st) = $m =~ m/Can't locate (.+?) in \@INC \(\@INC contains: (.+?)\) (.+)/gsm; 14 | 15 | $pack =~ s/[.]pm$//; 16 | $pack =~ s{/}{::}g; 17 | 18 | $st =~ s/\\n/\n\t/g; 19 | 20 | $inc = [split(/\s+/, $inc)]; 21 | 22 | print "Missing package: $pack\n"; 23 | print "Stack Trace: $st\n"; 24 | print "\@INC:\n"; 25 | print " $_\n" for @$inc; 26 | } 27 | 28 | __END__ 29 | [Wed Feb 08 22:38:28 2012] [error] Can't locate DBIx/Recordset.pm in @INC (@INC contains: /Users/melo/Documents/work/evolui/e1/elib/percy/lib /Users/melo/Documents/work/evolui/e1/elib/MyTK/lib /Users/melo/Documents/work/evolui/e1/lib /Users/melo/work/evolui/gestao/lib/common /Users/melo/work/evolui/e1/lib /Users/melo/work/evolui/e1/elib/MyTK/lib /Users/melo/work/evolui/e3/lib /Users/melo/work/evolui/e5/lib /Users/melo/work/evolui/e2/lib /usr/local/git/lib/site_perl/5.12.1 /Users/melo/perl5/perlbrew/perls/perl-5.14.1/lib/site_perl/5.14.1/darwin-2level /Users/melo/perl5/perlbrew/perls/perl-5.14.1/lib/site_perl/5.14.1 /Users/melo/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/darwin-2level /Users/melo/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1 . /Users/melo/apps/apache2) at /Users/melo/Documents/work/evolui/e1/lib/Tracking/Redirects.pm line 4.\nBEGIN failed--compilation aborted at /Users/melo/Documents/work/evolui/e1/lib/Tracking/Redirects.pm line 4.\nCompilation failed in require at /Users/melo/Documents/work/evolui/e1/lib/Evolui/BackOffice.pm line 6.\nBEGIN failed--compilation aborted at /Users/melo/Documents/work/evolui/e1/lib/Evolui/BackOffice.pm line 6.\nCompilation failed in require at /Users/melo/Documents/work/evolui/e1/lib/Evolui/BO/Campanha.pm line 5.\nBEGIN failed--compilation aborted at /Users/melo/Documents/work/evolui/e1/lib/Evolui/BO/Campanha.pm line 5.\nCompilation failed in require at /Users/melo/work/evolui/gestao/etc/apache/gestao/startup.pl line 86.\nBEGIN failed--compilation aborted at /Users/melo/work/evolui/gestao/etc/apache/gestao/startup.pl line 86.\nCompilation failed in require at (eval 2) line 1.\n -------------------------------------------------------------------------------- /bin/x-perl-hilite: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # hilite.pl - perl code colorizer on an ANSI terminal (xterm / putty session) 4 | # place this script in your path and make executable, e.g. 5 | # $ cp hilite.pl ~/bin/hilite 6 | # $ chmod 755 ~/bin/hilite 7 | # then run it to colorize text output that contains perl, e.g. 8 | # $ svn diff /some/path/MyModule.pm | hilite 9 | # and you get syntax colored text 10 | # 11 | # Source: http://blogs.perl.org/users/peter_edwards/2010/08/colorized-perl-code-snippets-on-ansi-terminals.html 12 | 13 | use strict; 14 | use warnings; 15 | use utf8; # ار 16 | use open ':utf8'; 17 | 18 | use Syntax::Highlight::Engine::Kate; 19 | use Term::ANSIColor qw(:constants); 20 | use IO::File; 21 | 22 | my $hl = new Syntax::Highlight::Engine::Kate( 23 | language => 'Perl', 24 | substitutions => {}, 25 | format_table => { 26 | Alert => [RED, RESET], 27 | BaseN => [RED, RESET], 28 | BString => [YELLOW, RESET], 29 | Char => [YELLOW, RESET], 30 | Comment => [CYAN, RESET], 31 | DataType => [GREEN, RESET], 32 | DecVal => [RED, RESET], 33 | Error => [RED, RESET], 34 | Float => [BRIGHT_RED, RESET], 35 | Function => [MAGENTA, RESET], 36 | IString => [MAGENTA, RESET], 37 | Keyword => [YELLOW, RESET], 38 | Normal => ["", ""], 39 | Operator => [BRIGHT_GREEN, RESET], 40 | Others => [MAGENTA, RESET], 41 | RegionMarker => [ON_GREEN, RESET], 42 | Reserved => [BLACK ON_BLUE, RESET], 43 | String => [MAGENTA, RESET], 44 | Variable => [BRIGHT_GREEN, RESET], 45 | Warning => [RED, RESET], 46 | }, 47 | ); 48 | 49 | my $fh; 50 | my $file = shift @ARGV; 51 | if ( !$file || $file eq '-' ) { 52 | binmode STDIN; 53 | $fh = \*STDIN; 54 | } 55 | else { 56 | $fh = IO::File->new($file) 57 | || die "Cannot open file: $file: $!"; 58 | } 59 | 60 | while ( my $line = <$fh> ) { 61 | print $hl->highlightText($line); 62 | }; 63 | -------------------------------------------------------------------------------- /bin/x-perl-method2sub2method: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | while (<>) { 7 | if (m/^method\s+(\S+)\s*(\(.+?\))?\s*\{\s*$/) { 8 | print "sub $1 { my \$self = shift; my $2 = \@_; #### METHOD MARKER $1 $2\n"; 9 | } 10 | elsif (m/^.+#### METHOD MARKER (\S+) (.+)$/) { 11 | print "method $1 $2 {\n"; 12 | } 13 | else { 14 | print $_; 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /bin/x-perl-module-info: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Loads a set of modules and print usefull information about them 4 | # 5 | # Pedro Melo 2004/12/23 6 | 7 | use strict; 8 | use warnings; 9 | 10 | usage() unless @ARGV; 11 | 12 | my @report; 13 | 14 | MODULE: 15 | foreach my $module (@ARGV) { 16 | my %info = ( name => $module ); 17 | push @report, \%info; 18 | 19 | my $fname = "$module.pm"; 20 | $fname =~ s/::/\//g; 21 | $info{file} = $fname; 22 | 23 | eval "require $module"; 24 | if (my $e = $@) { 25 | if ($e =~ /^Can't locate $fname/) { 26 | $info{not_found} = 1; 27 | } 28 | else { 29 | $info{not_loaded} = 1; 30 | $info{error} = $e; 31 | } 32 | 33 | next MODULE; 34 | } 35 | 36 | $info{version} = $module->VERSION; 37 | $info{path} = $INC{$fname}; 38 | } 39 | 40 | foreach my $info (@report) { 41 | my $name = $info->{name}; 42 | foreach my $f (qw( name version file path not_found not_loaded )) { 43 | print "$name $f: $info->{$f}\n" if $info->{$f}; 44 | } 45 | } 46 | 47 | ####### 48 | # Usage 49 | 50 | sub usage { 51 | print <recurse(callback => sub { 16 | my ($f) = @_; 17 | return if $f->is_dir; 18 | return unless $f->basename =~ /\.(pm|t)$/; 19 | 20 | _scan_file_for_uses($f); 21 | }); 22 | } 23 | 24 | printf('% -40s = 0%s', $_, "\n") for grep { ! /^E\d?:?/ } grep { ! /^(Digito|ENG|ESP|Evolui|FAQ|EvoluiESP|MPT|LMS|Prodigio|MyTK):?/ } sort keys %modules; 25 | 26 | sub _scan_file_for_uses { 27 | my $fh = shift->openr; 28 | while (<$fh>) { 29 | next if /^\s*use\s+(vars|utf8|lib|overload|version|strict|warnings|feature|encoding|5\.\d+)\b/; 30 | print STDERR " parse '$1'\n", next if /^\s*use\s+(?:parent|base)\b(.*);/; 31 | $modules{$1}++ if /^\s*use\s+([a-zA-Z0-9:]+)/; 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /bin/x-perl-send-test-reports: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # ** Send queued test reports ** 4 | # 5 | # I like to use CPAN::Reporter, but the default behavior of sending the 6 | # reports during my cpan runs is very slow. 7 | # 8 | # Fortunately, you can configure CPAN::Reporter to write the reports to 9 | # a directory, and later send them all in a batch. 10 | # 11 | # First you need to configure your CPAN::Reporter. Create a 12 | # $HOME/.cpanreporter/ directory and place a config.ini file inside with 13 | # the following content: 14 | # 15 | # ---- 8< ------ 16 | # email_from = melo@simplicidade.org 17 | # edit_report = no 18 | # 19 | # transport=File $QUEUE_DIR 20 | # ---- 8< ------ 21 | # 22 | # Adjust the email_from field to use your email, and adjust the 23 | # $QUEUE_DIR directory path in the last line. 24 | # 25 | # I use `/Users/melo/.cpan/reports` as my $QUEUE_DIR, for example. 26 | # 27 | # **Make sure the directory exists** 28 | # 29 | # $ mkdir -p /Users/melo/.cpan/reports 30 | # 31 | # Then make sure your cpan command is configured to use CPAN::Reporter. The easiest way is: 32 | # 33 | # $ cpan 34 | # cpan> o conf test_report 1 35 | # cpan> o conf commit 36 | # cpan> quit 37 | # 38 | # Done! You can now install your modules and a report will be created in 39 | # the $QUEUE_DIR directory 40 | # 41 | # After you create your reports, you can send them later with this script. Just run: 42 | # 43 | # $ x-perl-send-test-reports $QUEUE_DIR 44 | # 45 | # Reports will be renamed to .done after they are send. You can run the 46 | # script with --clean to remove those files. 47 | # 48 | 49 | use strict; 50 | use warnings; 51 | use 5.10.0; 52 | use Test::Reporter; 53 | use Getopt::Long; 54 | use Path::Class qw( dir ); 55 | 56 | my $opt_clean; 57 | my $opt_from; 58 | my $opt_server; 59 | my $opt_transport; 60 | 61 | my @queues = parse_arguments(); 62 | scan_all_queues(@queues); 63 | 64 | sub send_report { 65 | my ($file) = @_; 66 | 67 | my $tr = Test::Reporter->new; 68 | $tr->from($opt_from); 69 | $tr->mx([ $opt_server ]) if $opt_server; 70 | $tr->transport(split(/\s+/, $opt_transport)); 71 | $tr->via( 'x-perl-send-test-reports v0.1'); 72 | 73 | return if $tr->read($file)->send; 74 | return $tr->errstr; 75 | } 76 | 77 | sub send_reports_in_queue { 78 | my $q = shift; 79 | 80 | scan_queue($q, qr{[.]rpt$}, sub { 81 | my ($file) = @_; 82 | local $| = 1; 83 | 84 | my $subject = find_subject($file); 85 | next unless $subject; 86 | 87 | print "Sending report for '$subject'... "; 88 | if (my $error = send_report($file)) { 89 | print "FAIL\n>> Error: $error\n"; 90 | } 91 | else { 92 | if (rename($file, "$file.done")) { 93 | print "done!\n"; 94 | } 95 | else { 96 | print "FAIL\n>>> Could not mark '$subject' as DONE, will be resent.\n"; 97 | } 98 | } 99 | }); 100 | } 101 | 102 | sub scan_all_queues { 103 | for my $q (@_) { 104 | send_reports_in_queue($q); 105 | clean_reports_in_queue($q) if $opt_clean; 106 | } 107 | } 108 | 109 | sub clean_reports_in_queue { 110 | my ($q) = @_; 111 | 112 | scan_queue($q, qr{[.]done$}, sub { 113 | $_->remove && print "Cleaned up '$_'\n"; 114 | }); 115 | } 116 | 117 | sub scan_queue { 118 | my ($q, $regexp, $cb) = @_; 119 | 120 | ITEM: while (my $item = $q->next) { 121 | next ITEM unless -f $item; 122 | local $_ = $item; 123 | $cb->($item) if $item =~ /$regexp/; 124 | } 125 | } 126 | 127 | sub find_subject { 128 | my ($rpt) = @_; 129 | my $subject; 130 | 131 | my $fh = $rpt->openr; 132 | for (1..5) { 133 | my $line = <$fh>; 134 | last unless $line; 135 | 136 | $subject = $1 if $line =~ m/^Subject:\s*(.+)/; 137 | last if $subject; 138 | } 139 | $fh->close; 140 | 141 | return $subject; 142 | } 143 | 144 | sub parse_arguments { 145 | GetOptions( 146 | "from=s" => \$opt_from, 147 | "server=s" => \$opt_server, 148 | "transport=s" => \$opt_transport, 149 | "clean" => \$opt_clean, 150 | ) || usage(); 151 | 152 | usage('missing queue directory') unless @ARGV; 153 | usage('parameter --from is required') unless $opt_from; 154 | # usage('parameter --server is required') unless $opt_server; 155 | 156 | for my $q (@ARGV) { 157 | usage("queue '$q' is not a directory") unless -d $q; 158 | $q = dir($q); 159 | } 160 | 161 | return @ARGV; 162 | } 163 | 164 | sub usage { 165 | my $mesg = join('', @_); 166 | 167 | print <<'USAGE'; 168 | Send test reports created with CPAN::Reporter. 169 | 170 | Usage: x-perl-send-test-reports options queue1 ... 171 | 172 | Options: 173 | 174 | --from Email FROM address 175 | --server SMTP server to use 176 | --transport Tweak transport to use 177 | --clean Remove reports that where sent sucessfully 178 | 179 | Example: to send test reports via the GMail server: 180 | 181 | x-perl-send-test-reports --from your@email --server smtp.gmail.com \ 182 | --transport "Net::SMTP::TLS User your@email Password your_gmail_password Port 587" \ 183 | ~/.cpan/reports 184 | 185 | USAGE 186 | 187 | print "\nFATAL: $mesg\n" if $mesg; 188 | 189 | exit(1); 190 | } 191 | 192 | -------------------------------------------------------------------------------- /bin/x-perl-trace: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | LINE: 7 | while (my $line = <>) { 8 | print $line; 9 | 10 | if ($line =~ m/^\s*package\s*/) { 11 | print qq{our \$trace_frame_counter = 0; } 12 | } 13 | elsif (my ($sub) = $line =~ m/^sub\s+(\S+)/) { 14 | print qq{ local \$trace_frame_counter; \$trace_frame_counter++; ### TRACING\n}; 15 | print qq{ print STDERR "TRACE [\$trace_frame_counter] ($sub)\\n"; ### TRACING\n}; 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /bin/x-perldoc-html: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | tmp=`mktemp -t perldoc-html`.html 4 | 5 | perldoc -oHTML $@ > $tmp 6 | if [ -s "$tmp" ] ; then 7 | open -a Safari $tmp 8 | fi 9 | 10 | ( sleep 2 ; rm -f $tmp ) & 11 | -------------------------------------------------------------------------------- /bin/x-php2json: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use v5.10; 4 | use warnings; 5 | use PHP::Serialization (); 6 | use JSON::XS (); 7 | 8 | my $in = do { local $/; <> }; 9 | say JSON::XS->new->utf8->pretty->encode(PHP::Serialization::unserialize($in)); 10 | -------------------------------------------------------------------------------- /bin/x-pod: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # via http://babyl.dyndns.org/techblog/2010/01/local-pod-browsing-using-podpomweb-via-the-cli.html 4 | # by Yanick 5 | # 6 | # adjusted to Mac OS X by Pedro Melo 7 | # 8 | 9 | POD_PORT=8787 10 | 11 | perl -MPod::POM::Web \ 12 | -e"Pod::POM::Web->server($POD_PORT)" 2> /dev/null & 13 | 14 | PAGE=`perl -e's(::)(/)g for @ARGV; print @ARGV' $1` 15 | 16 | open "http://127.0.0.1:$POD_PORT/$PAGE" 17 | 18 | -------------------------------------------------------------------------------- /bin/x-pod-complete: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # bash completion script for x-pod 4 | # 5 | # by Yanick 6 | # via http://babyl.dyndns.org/techblog/2010/01/local-pod-browsing-using-podpomweb-via-the-cli.html 7 | # 8 | # Add to your .bashrc: 9 | # 10 | # complete -C x-pod-complete x-pod 11 | # 12 | 13 | use 5.010; 14 | use List::MoreUtils qw/ uniq /; 15 | 16 | my ( $sofar ) = reverse split ' ', $ENV{COMP_LINE}; 17 | 18 | $sofar =~ s(::)(/)g; 19 | 20 | my ( $path, $file ) = $sofar =~ m!^(.*/)?(.*)?$!; 21 | 22 | my @dirs = map { $_.'/'.$path } @INC; 23 | 24 | my @candidates; 25 | 26 | for ( @dirs ) { 27 | opendir my $dir, $_; 28 | push @candidates, grep { /^\Q$file/ } grep { !/^\.\.?$/ } readdir $dir; 29 | } 30 | 31 | if ( $path ) { 32 | $_ = $path.'/'.$_ for @candidates; 33 | } 34 | 35 | s/\.pm$// for @candidates; 36 | s(/+)(/)g for @candidates; 37 | 38 | say for uniq @candidates; 39 | 40 | -------------------------------------------------------------------------------- /bin/x-pod-server: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # via http://babyl.dyndns.org/techblog/2010/01/local-pod-browsing-using-podpomweb-via-the-cli.html 4 | # by Yanick 5 | # 6 | # adjusted to Mac OS X by Pedro Melo 7 | # 8 | 9 | POD_PORT=8787 10 | 11 | perl -MPod::POM::Web \ 12 | -e"Pod::POM::Web->server($POD_PORT)" 2> /dev/null & 13 | 14 | PAGE=`perl -e's(::)(/)g for @ARGV; print @ARGV' $1` 15 | 16 | open "http://127.0.0.1:$POD_PORT/$PAGE" 17 | 18 | -------------------------------------------------------------------------------- /bin/x-prove-since: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # 4 | 5 | ref=$1 6 | shift 7 | 8 | if [ -z "$ref" -o -z "$1" ] ; then 9 | echo "Usage: x-prove-since REF COMMAND" 10 | echo 11 | echo " Collects test files specified by REF, and" 12 | echo " run COMMAND on them" 13 | echo 14 | exit 1 15 | fi 16 | 17 | git diff --stat $ref \ 18 | | perl -ne '/^\s*(t\/.+[.]t)\s+\|/ && print "$1\0"' \ 19 | | xargs -0 $@ 20 | -------------------------------------------------------------------------------- /bin/x-prove-test-count: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # TAP::Harness (the module prove uses to keep track of total tests) 4 | # doesn't understand subtests, so it doesn't count them. 5 | # 6 | # The final report test count is only for top-level test count. Most of 7 | # the time, this is quite enough, but sometimes you want to know the 8 | # full test count. 9 | # 10 | # That's what this script does. 11 | # 12 | # You can run it in two ways: 13 | # 14 | # As a command, it will run prove for you, forcing -v (required for this 15 | # to work) and passes on all the extra parameters you give it 16 | # 17 | # x-prove-test-count x-prove-test-count -l --state=save 18 | # 19 | # Alternatively you can run it as a filter: 20 | # 21 | # prove -lv | x-prove-test-count 22 | # 23 | # Just don't forget to enable -v! 24 | # 25 | # Pedro Melo , at 2011/01/29 26 | 27 | use strict; 28 | use warnings; 29 | 30 | my $total = 0; 31 | 32 | my $prove_fh; 33 | if (-t \*STDIN) { 34 | ## Open and list form: only works on fork()-able OS's, so no Windows for you... 35 | open($prove_fh, '-|', 'prove', '-v', @ARGV); 36 | } 37 | else { 38 | $prove_fh = \*STDIN; 39 | } 40 | 41 | $|++; 42 | while (<$prove_fh>) { 43 | print; 44 | $total += $1 if m/^\s*1[.][.](\d+)\s*$/; 45 | } 46 | 47 | END { print "*** Total tests seen: $total\n" } 48 | -------------------------------------------------------------------------------- /bin/x-qmail-remove-bounce-from-queue: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Remove "remote" bounce messages from a qmail queue 4 | # 5 | 6 | queue=$1 7 | 8 | if [ -z "$queue" ] ; then 9 | echo "Usage: x-qmail-remove-bounce-from-queue QMAIL_QUEUE_DIR" 10 | exit 2 11 | fi 12 | 13 | cd $queue 14 | if [ $? != 0 ] ; then 15 | echo "FATAL: could not chdir to '$queue'" 16 | exit 1 17 | fi 18 | 19 | for dir in bounce info intd local lock mess pid remote todo ; do 20 | if [ ! -d $dir ] ; then 21 | echo "FATAL: '$queue' is not a valid qmail queue" 22 | exit 1 23 | fi 24 | done 25 | 26 | cd info 27 | if [ $? != 0 ] ; then 28 | echo "FATAL: could not chdir to '$queue/info'" 29 | exit 1 30 | fi 31 | 32 | for mess in `find . -type f -size 2c` ; do 33 | if [ ! -e ../remote/$mess ] ; then 34 | continue 35 | fi 36 | 37 | echo "Remove remote bounce $mess" 38 | rm -f ../{mess,remote,info}/$mess 39 | done 40 | 41 | -------------------------------------------------------------------------------- /bin/x-random: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | my ($n, $c) = @ARGV; 7 | $n = 1 unless $n; 8 | $c = 1 unless $c; 9 | 10 | while ($c--) { 11 | print rand($n),"\n"; 12 | } 13 | -------------------------------------------------------------------------------- /bin/x-redis-sniffer: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | echo "Redis proxy running at port 6378" 4 | tcpserver -RH 0 6378 recordio nc 127.0.0.1 6379 5 | -------------------------------------------------------------------------------- /bin/x-redis-start-server: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | workdir="$HOME/.redis-server" 4 | if [ ! -d "$workdir" ] ; then 5 | mkdir -p "$workdir" 6 | fi 7 | 8 | config= 9 | if [ -e "$workdir/redis.conf" ] ; then 10 | config="$workdir/redis.conf" 11 | fi 12 | 13 | server=${1:-redis-server} 14 | shift 15 | 16 | echo Starting... $server $config "$@" 17 | cd "$workdir" && exec $server $config "$@" > /dev/null & 18 | 19 | -------------------------------------------------------------------------------- /bin/x-setup-brew: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ## make sure all is up-to-date 4 | brew upgrade 5 | 6 | ## General utils we love 7 | brew install plenv perl-build nodeenv bash-completion git autojump nmap openssl \ 8 | docker-compose-completion docker-completion docker-compose-completion \ 9 | go hugo lego gnupg pinentry direnv jq awscli yarn pinentry-mac gpg 10 | 11 | brew install diff-so-fancy ## our git config uses this 12 | 13 | brew cask install aws-vault 14 | 15 | 16 | ## DuckDNS client 17 | brew tap jzelinskie/duckdns 18 | brew install duckdns 19 | 20 | 21 | # others 22 | brew install ag git-extras 23 | 24 | 25 | ## git compilation requires these 26 | brew install autoconf 27 | -------------------------------------------------------------------------------- /bin/x-setup-perl-modules: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cpanm -n JSON JSON::MaybeXS Cwd File::Spec::Functions Getopt::Long \ 4 | Data::Dump Data::Printer Time::Moment Text::Autoformat \ 5 | Pod::Cpandoc Code::TidyAll Perl::Tidy Pod::Tidy Mason::Tidy \ 6 | Code::TidyAll::Plugin::MasonTidy Code::TidyAll::Plugin::PodTidy \ 7 | Code::TidyAll::Plugin::Perl::IgnoreMethodSignaturesSimple \ 8 | Code::TidyAll::Plugin::Perl::AlignMooseAttributes \ 9 | Code::TidyAll::Plugin::PerlTidySweet \ 10 | Perl::LanguageServer Path::Tiny Digest::SHA CPAN::Mini \ 11 | LWP::Protocol::https Mozilla::CA HTTP::Tiny \ 12 | App::cpanminus Carton Devel::Cover PPI::HTML \ 13 | Pod::Text::Color::Delight \ 14 | Reply Term::ReadLine 15 | -------------------------------------------------------------------------------- /bin/x-setup-work-jumper: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # our work directory jump point 4 | # 5 | # To install add to .bashrc: 6 | # 7 | # . ~/path/to/x-setup-work-jumper 8 | # 9 | # Adds 'jj' command, try it 10 | # 11 | # Originaly it was just 'j', but then I discovered autojump which I also 12 | # like, and decided to rename this one 'jj' 13 | # 14 | # autojump is at https://github.com/joelthelion/autojump#readme 15 | # 16 | # Pedro Melo, 2011/10/22 17 | # 18 | 19 | work_jump_directory=${work_jump_directory:-$HOME/work} 20 | export work_jump_directory 21 | 22 | jj() 23 | { 24 | cd $1 25 | } 26 | 27 | _jj_complete() 28 | { 29 | local cur 30 | cur=$2 31 | 32 | if [ "${cur:0:${#work_jump_directory}}" != "$work_jump_directory" ] ; then 33 | cur="$work_jump_directory/$cur" 34 | fi 35 | 36 | COMPREPLY=( $( compgen -A directory "$cur" ) ) 37 | } 38 | 39 | complete -o nospace -S / -F _jj_complete jj 40 | -------------------------------------------------------------------------------- /bin/x-show-unicode-chars: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | binmode(\*STDOUT, ':utf8'); 7 | 8 | print "Type the hex value of the unicode char you want to see. ^D to exit.\n"; 9 | 10 | while (<>) { 11 | chomp; 12 | eval "print \"$_ => '\\x{$_}'\\n\""; 13 | } 14 | -------------------------------------------------------------------------------- /bin/x-sphinx-charset-generator: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Generates a charset_table entry for Sphinx 4 | # 5 | 6 | use strict; 7 | use warnings; 8 | use utf8; 9 | use Text::Unaccent; 10 | use Encode; 11 | 12 | my $map = gen_map_accents($ARGV[0] || 'utf-8'); 13 | 14 | print "charset_table=a..z,0..9,A..Z->a..z, \\\n"; 15 | print join(', ', map { sprintf('U+%X->%s', unpack('W*'), $map->{$_}) } sort keys %$map); 16 | print "\n"; 17 | 18 | sub gen_map_accents { 19 | my $charset = shift; 20 | my %map; 21 | 22 | my $src = 'áéíóúàèìòùãõâêîôûç'; 23 | $src .= uc($src); 24 | $src = encode($charset, $src) unless $charset =~ m/^utf-?8$/i; 25 | 26 | my $clean = lc(unac_string($charset, $src)); 27 | @map{split(//, $src)} = split(//, $clean); 28 | 29 | return \%map; 30 | } 31 | -------------------------------------------------------------------------------- /bin/x-sql-diff: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Diff two SQL schema files 4 | # 5 | # ** DRAFT ** WORK IN PROGRESS ** 6 | # 7 | # Pedro Melo , 2008/05/14 8 | 9 | 10 | # FIXME: use mktemp here 11 | base=/tmp/x-sql-diff 12 | old_sql=$base-old.sql 13 | new_sql=$base-new.sql 14 | diff_sql=$base-result.sql 15 | diff_errors=$base.errors 16 | 17 | # Clear AUTO_INCREMENTS, need to use copies 18 | cp $1 $old_sql 19 | cp $2 $new_sql 20 | perl -pi -e 's/AUTO_INCREMENT=\d+//g' $old_sql $new_sql 21 | 22 | # Do the diff 23 | sqlt-diff --ignore-index-names --ignore-constraint-names -c $old_sql=MySQL $new_sql=MySQL > $diff_sql 2> $diff_errors 24 | 25 | # Show the diff result 26 | echo 27 | echo 28 | cat $diff_sql 29 | echo 30 | echo 31 | 32 | if [ ! -s $diff_sql ] ; then 33 | echo 34 | echo "$diff_sql is empty, probably we got errors, check below" 35 | echo 36 | cat $diff_errors 37 | echo 38 | echo "End of error dump" 39 | echo 40 | exit 1 41 | fi 42 | 43 | action=n 44 | 45 | if [ "`head -1 $diff_sql`" != "No differences found." ] ; then 46 | echo "Keep the file or delete it? [k/D]" 47 | read action 48 | if [ "$action" == "k" ] ; then 49 | cp $diff_sql . 50 | echo $diff_sql is now in `pwd` 51 | fi 52 | else 53 | echo "**** Database is up-to-date, nothing required." 54 | fi 55 | 56 | rm -f $base* 57 | -------------------------------------------------------------------------------- /bin/x-ssh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Make sure we have a ssh master process before starting our own ssh 4 | # 5 | # Inspired by http://blog.woobling.org/2010/10/headless-virtualbox.html 6 | # 7 | # Forward configuration is only applied once, on the master process 8 | # 9 | # Suggestion: alias ssh=x-ssh 10 | # 11 | # Example configuration on .ssh/config: 12 | # 13 | # Host e-stage 14 | # HostName staging.host.name 15 | # User melo 16 | # ForwardAgent yes 17 | # Compression yes 18 | # ServerAliveInterval 120 19 | # ServerAliveCountMax 3 20 | # LocalForward 3307 127.0.0.1:3306 21 | # LocalForward 6380 127.0.0.1:6379 22 | # 23 | # ** YOU ALSO NEED THIS AT THE END OF .ssh/config ** 24 | # 25 | # Host * 26 | # ControlPath /tmp/ssh-master-control-%r-at-%h-port-%p.sock 27 | # ClearAllForwardings yes 28 | # 29 | # First time I ssh e-stage, all tunnels are setup; all others ssh e- 30 | # stage reuse the same connection 31 | 32 | function usage () 33 | { 34 | echo "Usage: x-ssh [ssh options]" 35 | exit 1 36 | } 37 | 38 | if [ -z "$1" ] ; then 39 | usage 40 | fi 41 | 42 | ssh -q -O check "$@" >/dev/null 2>&1 43 | if [ $? == 255 ] ; then 44 | ssh -N -f -q -o 'ClearAllForwardings no' -o 'ControlMaster yes' "$@" 45 | fi 46 | 47 | ssh -o 'ClearAllForwardings yes' "$@" 48 | -------------------------------------------------------------------------------- /bin/x-ssl-check-server-cert: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | openssl s_client -connect "$1" < /dev/null 2> /dev/null | \ 4 | perl -ne 'print if /^-----BEGIN CERTIFICATE-----/../^-----END CERTIFICATE-----/' | \ 5 | openssl x509 -text 6 | 7 | -------------------------------------------------------------------------------- /bin/x-ssl-self-signed-cert: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | site=$1 4 | 5 | if [ -z "$site" ] ; then 6 | echo "Usage: x-ssl-self-signed-cert DEST" 7 | exit 1 8 | fi 9 | 10 | openssl req \ 11 | -x509 -nodes -days 365 \ 12 | -newkey rsa:1024 \ 13 | -keyout ${site}.pem \ 14 | -out ${site}.pem 15 | -------------------------------------------------------------------------------- /bin/x-start-nsq: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | mkdir -p ~/workspace/nsq 4 | ( 5 | echo nsqlookupd 6 | echo nsqd --data-path ~/workspace/nsq/1 --lookupd-tcp-address '127.0.0.1:4160' 7 | echo nsqd --tcp-address='0.0.0.0:4152' --http-address='0.0.0.0:4153' --data-path ~/workspace/nsq/2 --lookupd-tcp-address '127.0.0.1:4160' 8 | echo nsqadmin --lookupd-http-address '127.0.0.1:4161' --notification-http-endpoint 'http://127.0.0.1:4151/pub?topic=nsqadmin.actions' 9 | echo nsq_tail --lookupd-http-address '127.0.0.1:4161' --topic 'nsqadmin.actions' 10 | ) | supervise-me 11 | -------------------------------------------------------------------------------- /bin/x-start-redis-server: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | workdir="$HOME/workspace/redis" 4 | if [ ! -d "$workdir" ] ; then 5 | mkdir -p "$workdir" 6 | fi 7 | 8 | config= 9 | if [ -e "$workdir/redis.conf" ] ; then 10 | config="$workdir/redis.conf" 11 | fi 12 | 13 | server=${1:-redis-server} 14 | shift 15 | 16 | LC_COLLATE='pt_PT.UTF-8' 17 | export LC_COLLATE 18 | 19 | echo Starting... $server $config "$@" 20 | cd "$workdir" && exec $server $config "$@" 21 | 22 | -------------------------------------------------------------------------------- /bin/x-stgit-update-to-latest-version: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Updates you stgit.git clone, recompiles, installs and activates the latest 4 | # version 5 | # 6 | 7 | # Set this to the place where stggit.git clone is at 8 | # in you local filesystem 9 | STGIT_CLONE_DIR=$HOME/work/track/stgit 10 | 11 | # Where all the git versions will be placed 12 | # Each version will be inside a directory, like v0.14.3-343-g0584ad1 13 | # Current active version will be a symblink 'stgit' 14 | # so you can add $BASE/stgit/bin to your PATH 15 | BASE=/usr/local 16 | 17 | ### Nothing more to tweak ### 18 | 19 | cd $STGIT_CLONE_DIR 20 | if [ $? != 0 ] ; then 21 | echo 22 | echo "** FATAL **: could not chdir to STGIT_CLONE_DIR $GIT_CLONE_DIR" 23 | echo "Edit this script and tell me where the stgit.git clone is" 24 | exit 1 25 | fi 26 | 27 | echo 28 | echo "This script will pull the lastest stgit.git master branch, recompile," 29 | echo "install and activate." 30 | echo 31 | echo "Sure? [y/N]" 32 | 33 | read confirmation 34 | 35 | if [ "$confirmation" != "y" ] ; then exit ; fi 36 | 37 | if [ -e configure ] ; then 38 | make distclean 39 | fi 40 | 41 | make clean 42 | git fetch; git merge origin/master 43 | 44 | version=`git describe --always` 45 | 46 | if [ -d "$BASE/stgit-$version" ] ; then 47 | echo 48 | echo "**** You already have the latest stgit version ($version) installed" 49 | echo 50 | exit 0 51 | fi 52 | 53 | echo 54 | echo "******* Compiling version $version" 55 | echo 56 | 57 | stgit_prefix=/usr/local/stgit-$version 58 | 59 | # TODO: install asciidoc/xmlto to support docs 60 | make prefix=$stgit_prefix all 61 | sudo make prefix=$stgit_prefix install 62 | 63 | echo 64 | echo "******* Cleanup phase" 65 | echo 66 | 67 | make clean 68 | 69 | 70 | echo 71 | echo "******* Check environment" 72 | echo 73 | 74 | check_path=`echo $PATH | perl -pe 's/:/\n/g' | egrep ^$BASE/stgit/bin$` 75 | if [ -z "$check_path" ] ; then 76 | echo 77 | echo "WARNING: your PATH must be changed to include" 78 | echo 79 | echo " $BASE/stgit/bin" 80 | echo 81 | fi 82 | 83 | echo 84 | echo Current stgit version: `readlink $BASE/stgit` 85 | echo Switching to version: stgit-$version 86 | echo 87 | 88 | sudo sh -c "cd $BASE; rm -f stgit; ln -s stgit-$version stgit" 89 | 90 | echo 91 | echo "You are running verion (running stgit -v now):" 92 | echo 93 | stg --version 94 | -------------------------------------------------------------------------------- /bin/x-sync-music: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Sync iTunes Music to Pen Drive 4 | # 5 | 6 | if [ ! -d /Volumes/MUSIC ] ; then 7 | echo "FATAL: mount pen drive labeled MUSIC to proceed" 8 | exit 1 9 | fi 10 | 11 | rsync -avm '/Users/melo/Music/iTunes/iTunes Music/' /Volumes/MUSIC/iTunes "$@" \ 12 | --delete \ 13 | --delete-excluded \ 14 | --exclude="Movies" \ 15 | --exclude="Your Mac Life" \ 16 | --exclude="WireTap Pro" \ 17 | --exclude="WebTalk Radio*" \ 18 | --exclude="Voice Memos" \ 19 | --exclude="O'Reilly *" \ 20 | --exclude="FLOSS*" \ 21 | --exclude="OSCON*" \ 22 | --exclude="Nuno Nunes*" \ 23 | --exclude="*Jon Udell*" \ 24 | --exclude="Boyd Timothy" \ 25 | --exclude="Open Source *" \ 26 | --exclude="slicehost *" \ 27 | --exclude="Griffin Tech*" \ 28 | --exclude="Dr. Moira Gunn*" \ 29 | --exclude="Perlcast*" \ 30 | --exclude="Podcasts" \ 31 | --exclude="Carson *" \ 32 | --exclude="Books" \ 33 | --exclude="*SD Forum*" \ 34 | --exclude="SXSW*" \ 35 | --exclude="*MySQL*" \ 36 | --exclude="IT Conversation*" \ 37 | --exclude="Mac OS X Conference*" \ 38 | --exclude="*ITC*" \ 39 | --exclude="MacNotables" \ 40 | --exclude="*CTO Connection*" \ 41 | --exclude="Core Intuition" \ 42 | --exclude="Douglas Adams" \ 43 | --include="*.mp3" \ 44 | --include="*.m4a" \ 45 | --include="*.m4p" \ 46 | --include="*/" \ 47 | --exclude="*" 48 | -------------------------------------------------------------------------------- /bin/x-terminal-clear: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Clears the current terminal *including* scrollback 4 | # 5 | # Based on a script at http://codesnippets.joyent.com/tag/screen#post1738 6 | # 7 | 8 | osascript -e 'tell application "System Events" to tell process "Terminal" to keystroke "k" using command down' 9 | clear 10 | -------------------------------------------------------------------------------- /bin/x-test-continuous: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Mac::FSEvents; 6 | use IO::Select; 7 | use Getopt::Long; 8 | use File::Spec::Functions qw( catfile ); 9 | use File::HomeDir; 10 | 11 | my $once; 12 | my $clear; 13 | my $script; 14 | my $ok = GetOptions( 15 | 'once' => \$once, 16 | 'clear' => \$clear, 17 | 'script=s' => \$script, 18 | ); 19 | usage() unless $ok; 20 | 21 | my @args = @ARGV; 22 | if ($script) { 23 | my $path = catfile(File::HomeDir->my_home, '.test-continuous.d', $script); 24 | usage(1, "Script '~/.test-continuous.d/$script' not found or not executable") 25 | unless -e $path && -x _; 26 | unshift @args, $path; 27 | } 28 | 29 | usage(1, "A command_to_execute is required") unless @args; 30 | 31 | run_command(@args) if $once; 32 | 33 | my @paths = ('./lib', './t'); 34 | my %fh_map; 35 | my $sel = IO::Select->new; 36 | 37 | foreach my $path (@paths) { 38 | my $fs = Mac::FSEvents->new({ 39 | path => $path, 40 | latency => 1.0, 41 | }); 42 | my $fh = $fs->watch; 43 | $sel->add($fh); 44 | $fh_map{$fh} = $fs; 45 | } 46 | 47 | while (my @fhs = $sel->can_read) { 48 | my $count = 0; 49 | foreach my $fh (@fhs) { 50 | $count += $fh_map{$fh}->read_events; 51 | } 52 | run_command(@args) if $count; 53 | } 54 | 55 | exit(0); 56 | 57 | END { map { $_->stop } keys %fh_map } 58 | 59 | 60 | ### Run the command 61 | sub run_command { 62 | system('/usr/bin/clear') if $clear; 63 | system(@_); 64 | print STDERR "Executed: ", join(' ', @_), "\n"; 65 | } 66 | 67 | 68 | ### Usage stuff 69 | sub usage { 70 | my ($code, $mesg) = @_; 71 | 72 | print STDERR <<'...'; 73 | Usage: x-test-continuous [options] [command_to_run] 74 | 75 | This utility watches the ./lib and ./t for modifications. 76 | If any modification is detected, a command is executed. 77 | 78 | If --clear is present, we run /usr/bin/clear before the command 79 | execution. 80 | 81 | The command can be given in two ways: using the --script NAME, or 82 | given the command on the command line. 83 | 84 | Options: 85 | 86 | --script NAME or -s NAME 87 | executes ~/.test-continuous/NAME; exits if not found 88 | --clear 89 | executes /usr/bin/clear before the command execution 90 | --once 91 | executes the command once before starting to watch the directories 92 | 93 | My usual use case is: 94 | 95 | x-test-continuous -- prove -l -v t 96 | 97 | You need -- to split the arguments for this script and the 98 | arguments for the command to execute. 99 | 100 | ... 101 | 102 | print STDERR "FATAL: $mesg\n\n" if $mesg; 103 | 104 | exit($code || 2); 105 | } 106 | 107 | -------------------------------------------------------------------------------- /bin/x-test-count: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | if (-t \*STDIN) { 7 | print <<" EOU"; 8 | Usage: | x-test-count 9 | 10 | Parses the TAP output and prints the number of ok/not ok test count, 11 | after all the input is spliced to the standard output. Requires 12 | prove to be run with verbose mode on. 13 | 14 | Usually prove shows that, but this script will also count subtests. 15 | 16 | TODO/SKIP tests are not supported. 17 | 18 | EOU 19 | exit(1); 20 | } 21 | 22 | my $ok = my $nok = 0; 23 | 24 | while (<>) { 25 | $ok++ if /^\s*ok\s+(\d+)\s/; 26 | $nok++ if /^\s*not ok\s+(\d+)\s/; 27 | print; 28 | } 29 | 30 | print "*** Detected $ok oks, $nok not oks, for a total of ".($ok+$nok)." test cases\n"; 31 | -------------------------------------------------------------------------------- /bin/x-text-autoformat: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Reformats a text file 4 | # 5 | # Pedro Melo , 2008/02/12 6 | 7 | use strict; 8 | use warnings; 9 | use Text::Autoformat; 10 | 11 | my $text = do { local $/; <> }; 12 | my $preamble; 13 | my %opts; 14 | 15 | if (my $filename = $ENV{TM_FILENAME}) { 16 | ## FIXME: use mime::types to fetch the content-type and use that to 17 | ## apply rules 18 | if ($filename =~ m/[.]m?md/) { ## MultiMarkdown, skip the metadata 19 | ($preamble, $text) = split(/\n\n/, $text, 2); 20 | $preamble .= "\n\n"; 21 | $opts{ignore} = qr{^![.a-z]*>\s+}; 22 | } 23 | } 24 | 25 | print $preamble if $preamble; 26 | print autoformat($text, {all => 1, %opts}); 27 | -------------------------------------------------------------------------------- /bin/x-text-recode: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use bytes; 6 | use Encode; 7 | use Getopt::Long; 8 | 9 | my ($to, $from, $list, $guess) = ('utf8', 'utf8'); 10 | my $ok = GetOptions( 11 | "from=s" => \$from, 12 | "to=s" => \$to, 13 | "list" => \$list, 14 | "guess" => \$guess, 15 | ); 16 | usage() unless $ok; 17 | 18 | if ($list) { 19 | if (-t \*STDOUT) { 20 | print "Supported encodings\n"; 21 | print "-------------------\n"; 22 | } 23 | foreach my $enc (Encode->encodings(":all")) { 24 | print $enc, "\n"; 25 | } 26 | exit(0); 27 | } 28 | 29 | if ($guess) { 30 | my $line = <>; 31 | foreach my $enc (Encode->encodings(":all")) { 32 | print $enc, "\t", encode($to, decode($enc, $line)); 33 | } 34 | exit(0); 35 | } 36 | 37 | while (<>) { 38 | print encode($to, decode($from, $_)); 39 | } 40 | -------------------------------------------------------------------------------- /bin/x-text-title-case-gruber: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # This filter changes all words to Title Caps, and attempts to be clever 4 | # about *un*capitalizing small words like a/an/the in the input. 5 | # 6 | # The list of "small words" which are not capped comes from 7 | # the New York Times Manual of Style, plus 'vs' and 'v'. 8 | # 9 | # John Gruber 10 | # http://daringfireball.net/ 11 | # 10 May 2008 12 | # 13 | # License: http://www.opensource.org/licenses/mit-license.php 14 | # 15 | 16 | 17 | use strict; 18 | use warnings; 19 | use utf8; 20 | use open IO => ":encoding(utf8)", # UTF8 by default 21 | ":std"; # Apply to STDIN/STDOUT/STDERR 22 | 23 | my @small_words = qw(a an and as at but by en for if in of on or the to v[.]? via vs[.]?); 24 | my $small_re = join '|', @small_words; 25 | 26 | while(<>) { 27 | my $line = ""; 28 | foreach my $s (split /( [:.;?!][ ] | (?:[ ]|^)["“] )/x) { 29 | $s =~ s{ 30 | \b( 31 | [[:alpha:]] 32 | [[:lower:].'’]* 33 | )\b 34 | }{ 35 | my $w = $1; 36 | # Skip words with inline dots, e.g. "del.icio.us" or "example.com" 37 | ($w =~ m{ [[:alpha:]] [.] [[:alpha:]] }x) ? 38 | $w : 39 | "\u\L$w"; 40 | }exg; 41 | 42 | # Lowercase our list of small words: 43 | $s =~ s{\b($small_re)\b}{\L$1}igo; 44 | 45 | 46 | # If the first word in the title is a small word, then capitalize it: 47 | $s =~ s{\A([[:punct:]]*)($small_re)\b}{$1\u$2}igo; 48 | 49 | # If the last word in the title is a small word, then capitalize it: 50 | $s =~ s{\b($small_re)([[:punct:]]*)\Z}{\u$1$2}igo; 51 | 52 | # Append current substring to output 53 | $line .= $s; 54 | } 55 | 56 | # Special Cases: 57 | $line =~ s{ V(s?)\. }{ v$1. }g; # "v." and "vs.": 58 | $line =~ s{(['’])S\b}{$1s}g; # 'S (otherwise you get "the SEC'S decision") 59 | $line =~ s{\b(AT&T|Q&A)\b}{\U$1}ig; # "AT&T" and "Q&A", which get tripped up by 60 | # self-contained small words "at" and "a" 61 | 62 | print $line; 63 | } 64 | 65 | __END__ 66 | 67 | -------------------------------------------------------------------------------- /bin/x-textile: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Text::Textile qw(textile); 6 | 7 | undef $/; 8 | print textile(scalar(<>)); -------------------------------------------------------------------------------- /bin/x-textmate-update-support-directory: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Update the TextMate Support directory from Subversion 4 | # 5 | # Recomended usage: run this from cron everyday with a 6 | # crontab entry like - 7 | # 8 | # 12 12 * * * PATH_TO/x-textmate-update-support-directory 9 | # 10 | # Pedro Melo , 2008/05/23 11 | 12 | 13 | export LC_CTYPE=en_US.UTF-8 14 | export LC_ALL= 15 | 16 | ## 10.5.8 has old svn, so use new one 17 | export PATH=/opt/subversion/bin:$PATH 18 | 19 | # Update main Application Support directory 20 | cd ~/work/textmate/system_config && svn --quiet update 21 | echo "---- Updated App support directory" 22 | 23 | # Check for updatable bundles in the personal Application Support directory 24 | cd ~/work/textmate/user_config 25 | 26 | for dir in `find . -name .git -type d` ; do 27 | ( cd $dir/.. && git pull --quiet && git gc --quiet ) 28 | echo "---- Updated $dir" 29 | done 30 | 31 | osascript -e 'tell app "TextMate" to reload bundles' 32 | echo "---- Reloaded bundles in TextMate" 33 | 34 | growlnotify -s "TextMate updated" -m "Support dir and local bundles updated" & 35 | -------------------------------------------------------------------------------- /bin/x-update-my-perl-environment: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | workdir=`mktemp -d -t my-perl-update-process` 4 | if [ ! -d "$workdir" ] ; then 5 | echo "Could not create temporary work directory: $!" 6 | exit 1 7 | fi 8 | cd $workdir 9 | 10 | which minicpan > /dev/null 11 | if [ $? == 1 ] ; then 12 | cpant -n CPAN::Mini 13 | fi 14 | minicpan 15 | 16 | git clone git://github.com/melo/task-belike-melo.git bootstrap 17 | cd bootstrap || exit 18 | 19 | which dzil > /dev/null 20 | if [ $? == 1 ] ; then 21 | cpant -n Dist::Zilla 22 | fi 23 | 24 | dzil authordeps | cpant -n 25 | dzil run cpant --installdeps -n . 26 | moose-outdated | cpant -n 27 | dzil run cpant --installdeps -n . 28 | 29 | cpan-outdated | cpant -n 30 | moose-outdated | cpant -n 31 | -------------------------------------------------------------------------------- /bin/x-video-info: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Video::Info; 6 | 7 | my $file = $ARGV[0]; 8 | print "Usage: x-video-info FILE\n" unless $file; 9 | 10 | my $video = Video::Info->new( -file => $file ); 11 | die "Could not open file $file\n" unless $video; 12 | 13 | my $vcodec = $video->vcodec; 14 | my $fps = $video->fps; 15 | my $frames = $video->vframes; 16 | my $duration = $video->duration; 17 | my $vrate = $video->vrate / 8; 18 | 19 | my $width = $video->width; 20 | my $height = $video->height; 21 | 22 | my $hours = int($duration/3600); 23 | my $mins = int(($duration-$hours*3600)/60); 24 | my $secs = $duration-$hours*3600-$mins*60; 25 | 26 | my $acodec = $video->acodec; 27 | my $n_chan = $video->achans; 28 | my $rate = $video->arate; 29 | my $freq = $video->afrequency; 30 | 31 | $rate = $rate / 1024; 32 | $freq = $freq / 1000; 33 | 34 | printf( 35 | 'Video Codec: %s (%.2f FPS, duration %0.2i:%0.2i:%0.2i, size %i x %i, rate %i Kbps)%s', 36 | $vcodec, $fps, $hours, $mins, $secs, $width, $height, $vrate, "\n", 37 | ); 38 | 39 | printf( 40 | 'Audio Codec: %s (%i channels, at %i kbps, %i KHz)%s', 41 | $acodec, $n_chan, $rate, $freq, "\n", 42 | ); 43 | 44 | -------------------------------------------------------------------------------- /bin/x-watch-fs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Mac::FSEvents; 6 | use IO::Select; 7 | use Getopt::Long; 8 | use File::Spec::Functions qw( catfile ); 9 | use File::HomeDir; 10 | 11 | my $opt_once; 12 | my $opt_clear; 13 | my $opt_script; 14 | my $opt_paths; 15 | my $ok = GetOptions( 16 | 'once' => \$opt_once, 17 | 'clear' => \$opt_clear, 18 | 'script=s' => \$opt_script, 19 | 'path=s@' => \@opt_paths, 20 | 'verbose' => \$opt_verbose, 21 | ); 22 | usage() unless $ok; 23 | 24 | my @args = @ARGV; 25 | if ($opt_script) { 26 | my $path = catfile(File::HomeDir->my_home, '.file-watchers.d', $script); 27 | usage(1, "Script '~/.file-watchers.d/$script' not found or not executable") 28 | unless -e $path && -x _; 29 | unshift @args, $path; 30 | } 31 | 32 | usage(1, "A command_to_execute is required") unless @args; 33 | 34 | run_command(@args) if $opt_once; 35 | 36 | my %fh_map; 37 | my $sel = IO::Select->new; 38 | 39 | @opt_paths = ('.') unless @opt_paths; 40 | for my $path (@opt_paths) { 41 | my $fs = Mac::FSEvents->new({ 42 | path => $path, 43 | latency => 1.0, 44 | }); 45 | my $fh = $fs->watch; 46 | $sel->add($fh); 47 | $fh_map{$fh} = $fs; 48 | } 49 | 50 | while (my @fhs = $sel->can_read) { 51 | my $count = 0; 52 | $count += $fh_map{$_}->read_events for @fhs; 53 | 54 | run_command(@args) if $count; 55 | } 56 | 57 | exit(0); 58 | 59 | END { map { $_->stop } keys %fh_map } 60 | 61 | 62 | ### Run the command 63 | sub run_command { 64 | system('/usr/bin/clear') if $opt_clear; 65 | system(@_); 66 | print STDERR "Executed: ", join(' ', @_), "\n" if $opt_verbose; 67 | } 68 | 69 | 70 | ### Usage stuff 71 | sub usage { 72 | my ($code, $mesg) = @_; 73 | 74 | print STDERR <<'...'; 75 | Usage: x-watch-fs [options] [command_to_run] 76 | 77 | This utility watches the files and/or directories for modifications 78 | If any modification is detected, a command is executed. 79 | 80 | If --clear is present, we run /usr/bin/clear before the command 81 | execution. 82 | 83 | The command can be given in two ways: using the --script NAME, or 84 | on the command line. 85 | 86 | Options: 87 | 88 | --script NAME or -s NAME 89 | executes ~/.fs-watcher.d/NAME; exits if not found 90 | --clear 91 | executes /usr/bin/clear before the command execution 92 | --once 93 | executes the command once before starting to watch the files/directories 94 | --path 95 | declares with files or directories should be watched; defaults 96 | to "." (current directory); can be used multiple times. 97 | 98 | An usual use case is: 99 | 100 | x-watch-fs --path t --path lib -- prove -l -v t 101 | 102 | You need -- to split the arguments for this script and the 103 | arguments for the command to execute. 104 | 105 | ... 106 | 107 | print STDERR "FATAL: $mesg\n\n" if $mesg; 108 | 109 | exit($code || 2); 110 | } 111 | -------------------------------------------------------------------------------- /bin/x-watch-load: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # x-watch-load: Sound the bell if the load levels rise above defined levels 4 | # 5 | # Pedro Melo (c) 2010 6 | # 7 | # Licensed in the terms of the Artistic License 2.0 8 | # See http://www.opensource.org/licenses/artistic-license-2.0.php 9 | # 10 | 11 | use strict; 12 | use warnings; 13 | 14 | my (@levels) = @ARGV; 15 | usage(1) unless @levels; 16 | 17 | $|++; 18 | while (1) { 19 | my @load = _read_uptime(); 20 | die "FATAL: Format of uptime unkown\n" unless @load; 21 | 22 | my $count = 0; 23 | for my $level (@levels) { 24 | $count++ if $load[0] > $level; 25 | } 26 | 27 | print "\rLoad average: ", join(', ', @load), ' '; 28 | print "\a" while $count--; 29 | sleep(2); 30 | } 31 | 32 | 33 | sub _read_uptime { 34 | my $uptime = `uptime`; 35 | return ($uptime =~ m/\s+([\d.]+)[,\s]+([\d.]+)[,\s]+([\d.]+)$/); 36 | } 37 | 38 | 39 | sub usage { 40 | print < (C) 2010 56 | 57 | LICENSE: Artistic License 2.0, 58 | see http://www.opensource.org/licenses/artistic-license-2.0.php 59 | 60 | EOU 61 | exit(1); 62 | } 63 | -------------------------------------------------------------------------------- /bin/x-xml-format-clipboard: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | pbpaste | xmllint --format - | pbcopy 4 | -------------------------------------------------------------------------------- /bin/x-xmpp-send: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Send a message to a XMPP ID using the Tarpipe SEND api 4 | # 5 | 6 | use strict; 7 | use warnings; 8 | use LWP::UserAgent; 9 | use HTTP::Request::Common qw( POST ); 10 | use Getopt::Long; 11 | 12 | my ($token, $message, @jids); 13 | my $ok = GetOptions( 14 | "token=s" => \$token, 15 | "message=s" => \$message, 16 | ); 17 | 18 | usage() unless $ok; 19 | usage('Missing JIDs') unless @ARGV; 20 | 21 | @jids = @ARGV; 22 | @ARGV = (); 23 | 24 | $message = _read_message_from_stdin() unless defined $message; 25 | $token = _read_xmpp_send_token() unless defined $token; 26 | 27 | chomp($message); 28 | 29 | my $ua = LWP::UserAgent->new; 30 | 31 | foreach my $jid (@jids) { 32 | my $request = POST('http://tarpipe.simplicidade.org:4335/send', [ 33 | token => $token, 34 | to => $jid, 35 | body => $message, 36 | ]); 37 | my $result = $ua->request($request); 38 | 39 | print "$jid: ", $result->code, ' ', $result->content, "\n"; 40 | } 41 | 42 | ######################################## 43 | # Read the token to use from config file 44 | 45 | sub _read_xmpp_send_token { 46 | my $path = $ENV{HOME}.'/.xmpp_send_token'; 47 | 48 | usage('Could not read token from configuration file') 49 | unless open(my $fh, '<', $path); 50 | 51 | my $token; 52 | local $_; 53 | while (<$fh>) { 54 | ($token) = m/^\s*([a-fA-F0-9]{32})\s*$/; 55 | last if $token; 56 | } 57 | 58 | return $token; 59 | } 60 | 61 | 62 | ######################### 63 | # Read message from STDIN 64 | 65 | sub _read_message_from_stdin { 66 | print "Type your message, hit CTRL-D to send, CTRL-C to abort.\n\n" if -t; 67 | 68 | local $/; 69 | return scalar(<>); 70 | } 71 | 72 | 73 | ####### 74 | # Usage 75 | 76 | sub usage { 77 | my ($mesg) = @_; 78 | 79 | print <<'EOU'; 80 | Usage: x-xmpp-send [-m|--message message] [-t|--token token] jid [jid]* 81 | 82 | If message is missing, it will read it from STDIN. 83 | 84 | If token is missing, we check the $HOME/.xmpp_send_token file. 85 | 86 | EOU 87 | 88 | print "FATAL: $mesg\n" if $mesg; 89 | 90 | exit(1); 91 | } 92 | -------------------------------------------------------------------------------- /bin/x-zeromq-pubsub-forwarder: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Start a PUBSUB ZeroMQ forwarder device: allow publishers and 4 | # subscribers to connect/disconnect from the topology at will 5 | # 6 | # x-zeromq-pubsub-forwarder SUB-endpoint PUB-endpoint 7 | # 8 | # Make all your publishers use SUB-endpoint and all your subscribers use 9 | # PUB-endpoint, both using connect(). 10 | # 11 | # Pedro Melo , 2012 12 | # License: Artistic V2 13 | # 14 | 15 | use strict; 16 | use warnings; 17 | 18 | use ZeroMQ qw/:all/; 19 | use ZeroMQ::Raw qw/zmq_device/; 20 | 21 | my ($sub_addr, $pub_addr) = @ARGV; 22 | usage() unless $sub_addr && $pub_addr; 23 | 24 | my $context = ZeroMQ::Context->new(); 25 | 26 | # Socket facing message sources 27 | my $frontend = $context->socket(ZMQ_SUB); 28 | $frontend->setsockopt(ZMQ_SUBSCRIBE, ''); 29 | $frontend->bind($sub_addr); 30 | 31 | # Socket facing message sinks 32 | my $backend = $context->socket(ZMQ_PUB); 33 | $backend->bind($pub_addr); 34 | 35 | # Start forwarder device 36 | zmq_device(ZMQ_FORWARDER, $frontend->socket, $backend->socket); 37 | 38 | sub usage { 39 | print < 41 | 42 | Start a PUBSUB ZeroMQ forwarder device: allow publishers and 43 | subscribers to connect/disconnect from the topology at will 44 | 45 | Make all your publishers use sub_endpoint and all your subscribers use 46 | pub_endpoint, both using connect(). 47 | EOU 48 | 49 | exit(1); 50 | } 51 | -------------------------------------------------------------------------------- /bin/x-zeromq-pubsub-subscriber: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | =pod 4 | 5 | ZeroMQ subscribers, accepts topic name to subscribe as parameter. 6 | 7 | =cut 8 | 9 | use strict; 10 | use warnings; 11 | 12 | use ZeroMQ qw/:all/; 13 | 14 | my ($addr, $topic_filter) = @ARGV; 15 | usage() unless $addr; 16 | 17 | my $ctx = ZeroMQ::Context->new(); 18 | 19 | my $sock = $ctx->socket(ZMQ_SUB); 20 | $sock->setsockopt(ZMQ_SUBSCRIBE, $topic_filter || ''); 21 | $sock->connect($addr); 22 | 23 | while (1) { 24 | my $topic = $sock->recv; 25 | my $msg = $sock->recv; 26 | print $topic->data, ': ', $msg->data, "\n"; 27 | } 28 | 29 | 30 | sub usage { 31 | print STDOUT < [] 33 | 34 | Connect a ZeroMQ SUB socket to addr, and listens for published 35 | messages. 36 | 37 | Assumes two-part messages, first is topic, second is data. 38 | 39 | You can use topic_filter as a prefix filter on topics. 40 | 41 | EOU 42 | 43 | exit(1); 44 | } 45 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'Path::Tiny'; 2 | requires 'Getopt::Long'; 3 | requires 'Module::CPANfile'; 4 | requires 'CPAN::Meta::Prereqs'; 5 | -------------------------------------------------------------------------------- /etc/tinyproxy.conf: -------------------------------------------------------------------------------- 1 | ## 2 | ## tinyproxy.conf -- tinyproxy daemon configuration file 3 | ## 4 | ## This example tinyproxy.conf file contains example settings 5 | ## with explanations in comments. For decriptions of all 6 | ## parameters, see the tinproxy.conf(5) manual page. 7 | ## 8 | 9 | # 10 | # User/Group: This allows you to set the user and group that will be 11 | # used for tinyproxy after the initial binding to the port has been done 12 | # as the root user. Either the user or group name or the UID or GID 13 | # number may be used. 14 | # 15 | #User melo 16 | #Group staff 17 | 18 | # 19 | # Port: Specify the port which tinyproxy will listen on. Please note 20 | # that should you choose to run on a port lower than 1024 you will need 21 | # to start tinyproxy using root. 22 | # 23 | Port 8469 24 | 25 | # 26 | # Listen: If you have multiple interfaces this allows you to bind to 27 | # only one. If this is commented out, tinyproxy will bind to all 28 | # interfaces present. 29 | # 30 | Listen 127.0.0.1 31 | 32 | # 33 | # Bind: This allows you to specify which interface will be used for 34 | # outgoing connections. This is useful for multi-home'd machines where 35 | # you want all traffic to appear outgoing from one particular interface. 36 | # 37 | # Office Fig 38 | #Bind 10.9.8.13 39 | # Office ISI 40 | #Bind 10.119.12.152 41 | # Casa 42 | #Bind 192.168.1.72 43 | # Porto 5piso 44 | #Bind 192.168.1.66 45 | 46 | # 47 | # BindSame: If enabled, tinyproxy will bind the outgoing connection to the 48 | # ip address of the incoming connection. 49 | # 50 | BindSame no 51 | 52 | # 53 | # Timeout: The maximum number of seconds of inactivity a connection is 54 | # allowed to have before it is closed by tinyproxy. 55 | # 56 | Timeout 600 57 | 58 | # 59 | # ErrorFile: Defines the HTML file to send when a given HTTP error 60 | # occurs. You will probably need to customize the location to your 61 | # particular install. The usual locations to check are: 62 | # /usr/local/share/tinyproxy 63 | # /usr/share/tinyproxy 64 | # /etc/tinyproxy 65 | # 66 | #ErrorFile 404 "/Users/melo/.homebrew/Cellar/tinyproxy/1.8.3/share/tinyproxy/404.html" 67 | #ErrorFile 400 "/Users/melo/.homebrew/Cellar/tinyproxy/1.8.3/share/tinyproxy/400.html" 68 | #ErrorFile 503 "/Users/melo/.homebrew/Cellar/tinyproxy/1.8.3/share/tinyproxy/503.html" 69 | #ErrorFile 403 "/Users/melo/.homebrew/Cellar/tinyproxy/1.8.3/share/tinyproxy/403.html" 70 | #ErrorFile 408 "/Users/melo/.homebrew/Cellar/tinyproxy/1.8.3/share/tinyproxy/408.html" 71 | 72 | # 73 | # DefaultErrorFile: The HTML file that gets sent if there is no 74 | # HTML file defined with an ErrorFile keyword for the HTTP error 75 | # that has occured. 76 | # 77 | DefaultErrorFile "/Users/melo/.homebrew/Cellar/tinyproxy/1.8.3/share/tinyproxy/default.html" 78 | 79 | # 80 | # StatHost: This configures the host name or IP address that is treated 81 | # as the stat host: Whenever a request for this host is received, 82 | # Tinyproxy will return an internal statistics page instead of 83 | # forwarding the request to that host. The default value of StatHost is 84 | # tinyproxy.stats. 85 | # 86 | StatHost "tinyproxy.stats" 87 | # 88 | 89 | # 90 | # StatFile: The HTML file that gets sent when a request is made 91 | # for the stathost. If this file doesn't exist a basic page is 92 | # hardcoded in tinyproxy. 93 | # 94 | StatFile "/Users/melo/.homebrew/Cellar/tinyproxy/1.8.3/share/tinyproxy/stats.html" 95 | 96 | # 97 | # LogFile: Allows you to specify the location where information should 98 | # be logged to. If you would prefer to log to syslog, then disable this 99 | # and enable the Syslog directive. These directives are mutually 100 | # exclusive. 101 | # 102 | LogFile "/Users/melo/logs/tinyproxy/tinyproxy.log" 103 | 104 | # 105 | # Syslog: Tell tinyproxy to use syslog instead of a logfile. This 106 | # option must not be enabled if the Logfile directive is being used. 107 | # These two directives are mutually exclusive. 108 | # 109 | #Syslog On 110 | 111 | # 112 | # LogLevel: 113 | # 114 | # Set the logging level. Allowed settings are: 115 | # Critical (least verbose) 116 | # Error 117 | # Warning 118 | # Notice 119 | # Connect (to log connections without Info's noise) 120 | # Info (most verbose) 121 | # 122 | # The LogLevel logs from the set level and above. For example, if the 123 | # LogLevel was set to Warning, then all log messages from Warning to 124 | # Critical would be output, but Notice and below would be suppressed. 125 | # 126 | LogLevel Info 127 | 128 | # 129 | # PidFile: Write the PID of the main tinyproxy thread to this file so it 130 | # can be used for signalling purposes. 131 | # 132 | PidFile "/Users/melo/logs/tinyproxy/tinyproxy.pid" 133 | 134 | # 135 | # XTinyproxy: Tell Tinyproxy to include the X-Tinyproxy header, which 136 | # contains the client's IP address. 137 | # 138 | #XTinyproxy Yes 139 | 140 | # 141 | # Upstream: 142 | # 143 | # Turns on upstream proxy support. 144 | # 145 | # The upstream rules allow you to selectively route upstream connections 146 | # based on the host/domain of the site being accessed. 147 | # 148 | # For example: 149 | # # connection to test domain goes through testproxy 150 | # upstream testproxy:8008 ".test.domain.invalid" 151 | # upstream testproxy:8008 ".our_testbed.example.com" 152 | # upstream testproxy:8008 "192.168.128.0/255.255.254.0" 153 | # 154 | # # no upstream proxy for internal websites and unqualified hosts 155 | # no upstream ".internal.example.com" 156 | # no upstream "www.example.com" 157 | # no upstream "10.0.0.0/8" 158 | # no upstream "192.168.0.0/255.255.254.0" 159 | # no upstream "." 160 | # 161 | # # connection to these boxes go through their DMZ firewalls 162 | # upstream cust1_firewall:8008 "testbed_for_cust1" 163 | # upstream cust2_firewall:8008 "testbed_for_cust2" 164 | # 165 | # # default upstream is internet firewall 166 | # upstream firewall.internal.example.com:80 167 | # 168 | # The LAST matching rule wins the route decision. As you can see, you 169 | # can use a host, or a domain: 170 | # name matches host exactly 171 | # .name matches any host in domain "name" 172 | # . matches any host with no domain (in 'empty' domain) 173 | # IP/bits matches network/mask 174 | # IP/mask matches network/mask 175 | # 176 | #Upstream some.remote.proxy:port 177 | 178 | # 179 | # MaxClients: This is the absolute highest number of threads which will 180 | # be created. In other words, only MaxClients number of clients can be 181 | # connected at the same time. 182 | # 183 | MaxClients 100 184 | 185 | # 186 | # MinSpareServers/MaxSpareServers: These settings set the upper and 187 | # lower limit for the number of spare servers which should be available. 188 | # 189 | # If the number of spare servers falls below MinSpareServers then new 190 | # server processes will be spawned. If the number of servers exceeds 191 | # MaxSpareServers then the extras will be killed off. 192 | # 193 | MinSpareServers 5 194 | MaxSpareServers 20 195 | 196 | # 197 | # StartServers: The number of servers to start initially. 198 | # 199 | StartServers 10 200 | 201 | # 202 | # MaxRequestsPerChild: The number of connections a thread will handle 203 | # before it is killed. In practise this should be set to 0, which 204 | # disables thread reaping. If you do notice problems with memory 205 | # leakage, then set this to something like 10000. 206 | # 207 | MaxRequestsPerChild 0 208 | 209 | # 210 | # Allow: Customization of authorization controls. If there are any 211 | # access control keywords then the default action is to DENY. Otherwise, 212 | # the default action is ALLOW. 213 | # 214 | # The order of the controls are important. All incoming connections are 215 | # tested against the controls based on order. 216 | # 217 | Allow 127.0.0.1 218 | 219 | # 220 | # AddHeader: Adds the specified headers to outgoing HTTP requests that 221 | # Tinyproxy makes. Note that this option will not work for HTTPS 222 | # traffic, as Tinyproxy has no control over what headers are exchanged. 223 | # 224 | #AddHeader "X-My-Header" "Powered by Tinyproxy" 225 | 226 | # 227 | # ViaProxyName: The "Via" header is required by the HTTP RFC, but using 228 | # the real host name is a security concern. If the following directive 229 | # is enabled, the string supplied will be used as the host name in the 230 | # Via header; otherwise, the server's host name will be used. 231 | # 232 | ViaProxyName "tinyproxy" 233 | 234 | # 235 | # DisableViaHeader: When this is set to yes, Tinyproxy does NOT add 236 | # the Via header to the requests. This virtually puts Tinyproxy into 237 | # stealth mode. Note that RFC 2616 requires proxies to set the Via 238 | # header, so by enabling this option, you break compliance. 239 | # Don't disable the Via header unless you know what you are doing... 240 | # 241 | #DisableViaHeader Yes 242 | 243 | # 244 | # Filter: This allows you to specify the location of the filter file. 245 | # 246 | #Filter "/Users/melo/.homebrew/Cellar/tinyproxy/1.8.3/etc/filter" 247 | 248 | # 249 | # FilterURLs: Filter based on URLs rather than domains. 250 | # 251 | #FilterURLs On 252 | 253 | # 254 | # FilterExtended: Use POSIX Extended regular expressions rather than 255 | # basic. 256 | # 257 | #FilterExtended On 258 | 259 | # 260 | # FilterCaseSensitive: Use case sensitive regular expressions. 261 | # 262 | #FilterCaseSensitive On 263 | 264 | # 265 | # FilterDefaultDeny: Change the default policy of the filtering system. 266 | # If this directive is commented out, or is set to "No" then the default 267 | # policy is to allow everything which is not specifically denied by the 268 | # filter file. 269 | # 270 | # However, by setting this directive to "Yes" the default policy becomes 271 | # to deny everything which is _not_ specifically allowed by the filter 272 | # file. 273 | # 274 | #FilterDefaultDeny Yes 275 | 276 | # 277 | # Anonymous: If an Anonymous keyword is present, then anonymous proxying 278 | # is enabled. The headers listed are allowed through, while all others 279 | # are denied. If no Anonymous keyword is present, then all headers are 280 | # allowed through. You must include quotes around the headers. 281 | # 282 | # Most sites require cookies to be enabled for them to work correctly, so 283 | # you will need to allow Cookies through if you access those sites. 284 | # 285 | #Anonymous "Host" 286 | #Anonymous "Authorization" 287 | #Anonymous "Cookie" 288 | 289 | # 290 | # ConnectPort: This is a list of ports allowed by tinyproxy when the 291 | # CONNECT method is used. To disable the CONNECT method altogether, set 292 | # the value to 0. If no ConnectPort line is found, all ports are 293 | # allowed (which is not very secure.) 294 | # 295 | # The following two ports are used by SSL. 296 | # 297 | ConnectPort 443 298 | ConnectPort 563 299 | 300 | # 301 | # Configure one or more ReversePath directives to enable reverse proxy 302 | # support. With reverse proxying it's possible to make a number of 303 | # sites appear as if they were part of a single site. 304 | # 305 | # If you uncomment the following two directives and run tinyproxy 306 | # on your own computer at port 8888, you can access Google using 307 | # http://localhost:8888/google/ and Wired News using 308 | # http://localhost:8888/wired/news/. Neither will actually work 309 | # until you uncomment ReverseMagic as they use absolute linking. 310 | # 311 | #ReversePath "/google/" "http://www.google.com/" 312 | #ReversePath "/wired/" "http://www.wired.com/" 313 | 314 | # 315 | # When using tinyproxy as a reverse proxy, it is STRONGLY recommended 316 | # that the normal proxy is turned off by uncommenting the next directive. 317 | # 318 | #ReverseOnly Yes 319 | 320 | # 321 | # Use a cookie to track reverse proxy mappings. If you need to reverse 322 | # proxy sites which have absolute links you must uncomment this. 323 | # 324 | #ReverseMagic Yes 325 | 326 | # 327 | # The URL that's used to access this reverse proxy. The URL is used to 328 | # rewrite HTTP redirects so that they won't escape the proxy. If you 329 | # have a chain of reverse proxies, you'll need to put the outermost 330 | # URL here (the address which the end user types into his/her browser). 331 | # 332 | # If not set then no rewriting occurs. 333 | # 334 | #ReverseBaseURL "http://localhost:8888/" 335 | 336 | 337 | 338 | --------------------------------------------------------------------------------