├── .appveyor.yml ├── .gitattributes ├── .github ├── bin │ └── labeler ├── labeler.yml └── workflows │ ├── closed_pull_request.yml │ ├── linux.yml │ ├── macos.yml │ ├── new_pull_request.yml │ ├── pr-labeler.yml │ ├── release.yml │ └── windows.yml ├── .gitignore ├── .perltidyrc ├── .releaserc ├── CNAME ├── CONTRIBUTING.md ├── Changes ├── INSTALL.SKIP ├── LICENSE-ARTISTIC2 ├── LICENSE-BSD2 ├── LICENSE-GPL2 ├── MANIFEST ├── MANIFEST.SKIP ├── META.yml ├── Makefile.PL ├── PROGRAMMING_STYLE.md ├── README.pod ├── TODO ├── bin ├── addbib ├── apply ├── ar ├── arch ├── arithmetic ├── asa ├── awk ├── banner ├── base64 ├── basename ├── bc ├── bcd ├── cal ├── cat ├── chgrp ├── ching ├── chmod ├── chown ├── clear ├── cmp ├── col ├── colrm ├── comm ├── cp ├── cut ├── date ├── dc ├── deroff ├── diff ├── dirname ├── du ├── echo ├── ed ├── env ├── expand ├── expr ├── factor ├── false ├── file ├── find ├── fish ├── fmt ├── fold ├── fortune ├── from ├── glob ├── grep ├── hangman ├── head ├── hexdump ├── id ├── install ├── join ├── kill ├── ln ├── lock ├── look ├── ls ├── mail ├── maze ├── mimedecode ├── mkdir ├── mkfifo ├── moo ├── morse ├── nl ├── od ├── par ├── paste ├── patch ├── perldoc ├── perlpowertools ├── pig ├── ping ├── pom ├── ppt ├── pr ├── primes ├── printenv ├── printf ├── pwd ├── rain ├── random ├── rev ├── rm ├── rmdir ├── robots ├── rot13 ├── seq ├── shar ├── sleep ├── sort ├── spell ├── split ├── strings ├── sum ├── tac ├── tail ├── tar ├── tee ├── test ├── time ├── touch ├── tr ├── true ├── tsort ├── tty ├── uname ├── unexpand ├── uniq ├── units ├── unlink ├── unpar ├── unshar ├── uudecode ├── uuencode ├── wc ├── what ├── which ├── whoami ├── whois ├── words ├── wump ├── xargs └── yes ├── data ├── commands.json ├── commands.txt ├── definitions.units └── unittab ├── lib ├── PerlPowerTools.pm ├── PerlPowerTools │ └── SymbolicMode.pm └── ppt.pm ├── packed └── perlpowertools ├── packer └── packer.pl ├── t ├── 000.basic.t ├── 910.meta.t ├── 990.pod.t ├── bc │ └── input.t ├── cat │ └── cat.t ├── cp │ └── gh-115-copy-into-dir.t ├── cut │ └── cut.t ├── data │ ├── cat │ │ └── cat-n-1.txt │ ├── nl │ │ └── nl.txt │ ├── od │ │ └── ascii.txt │ ├── rev │ │ └── reverse-this.txt │ └── sort │ │ ├── ints1.txt │ │ ├── letters1.txt │ │ └── three-words.txt ├── date │ └── date.t ├── echo │ └── echo.t ├── factor │ └── factor.t ├── false │ └── false.t ├── find │ └── find.t ├── glob │ └── glob.t ├── lib │ ├── common.pl │ └── utils.pm ├── ls │ └── ls.t ├── mimedecode │ └── 000.basic.t ├── nl │ └── nl.t ├── od │ └── od.t ├── rev │ └── rev.t ├── rm │ ├── process_options.t │ └── run.t ├── robots │ └── 000.basic.t ├── rot13 │ └── rot13.t ├── seq │ └── seq.t ├── sort │ └── sort.t ├── true │ └── true.t ├── units │ └── units.t └── uudecode │ └── uudecode.t ├── util ├── create_tool_list ├── date │ ├── test_dates.pl │ ├── tz.txt.pl │ └── windows_tz.pl ├── extract_metadata ├── list_changes ├── make_labeler_config ├── make_test_files └── merge-labeler └── xt ├── changes.t ├── perlcritic.t ├── perlcriticrc └── pod.t /.appveyor.yml: -------------------------------------------------------------------------------- 1 | # brian's standard Appveyor config for Perl 5 modules 2 | # https://github.com/briandfoy/brians_perl_modules_appveyor_config 3 | # This file is licensed under the Artistic License 2.0 4 | # version 20230308 5 | --- 6 | image: 7 | - Visual Studio 2019 8 | - Visual Studio 2022 9 | - ubuntu2004 10 | 11 | environment: 12 | PERL5LIB: /home/appveyor/perl5/lib/perl5 13 | DEBIAN_FRONTEND: noninteractive 14 | SP: C:\strawberry 15 | 16 | platform: x64 17 | 18 | branches: 19 | only: 20 | - master 21 | - appveyor 22 | 23 | skip_tags: true 24 | 25 | install: 26 | - cmd: if not exist "C:\strawberry" cinst strawberryperl 27 | - cmd: set PATH=%SP%\perl\bin;%SP%\perl\site\bin;%SP%\c\bin;%PATH% 28 | - cmd: cd %APPVEYOR_BUILD_FOLDER% 29 | - sh: sudo apt-get update --allow-releaseinfo-change 30 | - sh: sudo env apt-get -yq install build-essential git libssl-dev 31 | - sh: sudo apt-get install -y perl 32 | - sh: export PATH=/home/appveyor/perl5/bin:$PATH 33 | - perl -v 34 | - cpan -M https://www.cpan.org -T App::cpanminus ExtUtils::MakeMaker 35 | - cmd: cpanm --notest --installdeps . 36 | - sh: cpanm --local-lib=/home/appveyor/perl5 --notest --installdeps . 37 | 38 | build_script: 39 | - perl Makefile.PL 40 | - cmd: gmake test 41 | - sh: make test 42 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # https://github.com/github/linguist/blob/master/docs/overrides.md#using-gitattributes 2 | *.t linguist-language=Perl 3 | *.pl linguist-language=Perl 4 | *.pm linguist-language=Perl 5 | -------------------------------------------------------------------------------- /.github/bin/labeler: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use v5.10; 3 | use IPC::Open3; 4 | 5 | use subs qw(verbose); 6 | 7 | my( $issue_no, $command, @labels ) = @ARGV; 8 | $command //= 'remove'; 9 | 10 | my $existing_labels = get_existing_labels($issue_no); 11 | verbose "Existing labels are " . join " ", keys %$existing_labels; 12 | 13 | my $action; 14 | 15 | if( $command eq 'add' ) { 16 | @labels = get_default_labels_to_add() if @labels == 0; 17 | verbose "Labels to add (before): " . join " ", @labels; 18 | 19 | @labels = grep { ! exists $existing_labels->{$_} } @labels; 20 | } 21 | elsif( $command eq 'remove' ) { 22 | @labels = get_default_labels_to_remove() if @labels == 0; 23 | verbose "Labels to remove (before): " . join " ", @labels; 24 | 25 | @labels = grep { exists $existing_labels->{$_} } @labels; 26 | } 27 | 28 | verbose "Labels to $command (after): " . join " ", @labels; 29 | 30 | label_action( $issue_no, $command, @labels ); 31 | 32 | sub get_default_labels_to_add { 33 | return ( 34 | 'Priority: low', 35 | 'Status: needs verification', 36 | 'Type: bug' 37 | ); 38 | } 39 | 40 | sub get_default_labels_to_remove { 41 | chomp( my @labels = `gh label list --json name --jq .[].name` ); 42 | @labels = grep { /\A (?:Status|Priority) : /x } @labels; 43 | } 44 | 45 | sub get_existing_labels { 46 | my( $issue ) = @_; 47 | 48 | chomp( my @l = `gh issue view $issue --json labels --jq .labels.[].name` ); 49 | my %h = map { $_, 1 } @l; 50 | return \%h 51 | } 52 | 53 | sub label_action { 54 | my( $issue_no, $command, @labels ) = @_; 55 | my $switch = "--${command}-label"; 56 | 57 | if( @labels == 0 ) { 58 | say "No labels to $command"; 59 | return 60 | }; 61 | 62 | my @command = qw(gh issue edit); 63 | push @command, $issue_no; 64 | 65 | foreach (@labels) { 66 | push @command, $switch, $_; 67 | } 68 | 69 | verbose "COMMAND: @command"; 70 | 71 | my $rc = system @command; 72 | verbose "[$rc] Removed labels: @labels"; 73 | } 74 | 75 | sub verbose { 76 | return unless $ENV{VERBOSE}; 77 | say STDOUT '::notice::', @_; 78 | } 79 | -------------------------------------------------------------------------------- /.github/workflows/closed_pull_request.yml: -------------------------------------------------------------------------------- 1 | name: "Closed Pull Request Labeler" 2 | on: 3 | pull_request_target: 4 | types: 5 | - closed 6 | 7 | env: 8 | GH_TOKEN: ${{ github.token }} 9 | VERBOSE: ${{ vars.VERBOSE }} 10 | 11 | jobs: 12 | merged: 13 | if: github.event.pull_request.merged == true 14 | environment: housekeeping 15 | permissions: 16 | contents: read 17 | pull-requests: write 18 | runs-on: ubuntu-latest 19 | steps: 20 | - uses: actions/checkout@v3 21 | - run: | 22 | perl .github/bin/labeler ${{ github.event.number }} remove 23 | perl .github/bin/labeler ${{ github.event.number }} add 'Status: accepted' 24 | rejected: 25 | if: github.event.pull_request.merged == false 26 | environment: housekeeping 27 | permissions: 28 | contents: read 29 | pull-requests: write 30 | runs-on: ubuntu-latest 31 | steps: 32 | - uses: actions/checkout@v3 33 | - run: | 34 | perl .github/bin/labeler ${{ github.event.number }} remove 35 | perl .github/bin/labeler ${{ github.event.number }} add 'Status: rejected' 36 | -------------------------------------------------------------------------------- /.github/workflows/new_pull_request.yml: -------------------------------------------------------------------------------- 1 | name: "New Pull Request Labeler" 2 | on: 3 | pull_request_target: 4 | types: 5 | - opened 6 | 7 | env: 8 | GH_TOKEN: ${{ github.token }} 9 | 10 | jobs: 11 | new_pull_request: 12 | environment: housekeeping 13 | permissions: 14 | contents: read 15 | pull-requests: write 16 | runs-on: ubuntu-latest 17 | steps: 18 | - uses: actions/checkout@v3 19 | - run: | 20 | perl .github/bin/labeler ${{ github.event.number }} add 21 | - uses: hkusu/review-assign-action@v1 22 | with: 23 | assignees: ${{ vars.ASSIGNEES }} 24 | -------------------------------------------------------------------------------- /.github/workflows/pr-labeler.yml: -------------------------------------------------------------------------------- 1 | name: "Pull Request Labeler" 2 | on: 3 | pull_request_target: 4 | types: 5 | - opened 6 | 7 | 8 | jobs: 9 | triage: 10 | permissions: 11 | contents: read 12 | pull-requests: write 13 | runs-on: ubuntu-latest 14 | steps: 15 | - uses: actions/checkout@v3 16 | # https://github.com/marketplace/actions/labeler 17 | - uses: actions/labeler@v4 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | !Build/ 2 | *.bbproj 3 | *.bs 4 | *.o 5 | *.rej 6 | *.tar 7 | *.tar.gz 8 | *.tgz 9 | *.zip 10 | .last_cover_stats 11 | .prove 12 | /.build/ 13 | /MANIFEST.bak 14 | /META.* 15 | /MYMETA.* 16 | /Makefile 17 | /Makefile.old 18 | /blib/ 19 | /pm_to_blib 20 | Build 21 | Build.bat 22 | _build/ 23 | cover_db/ 24 | inc/ 25 | nytprof.out 26 | MYMETA* 27 | Makefile 28 | blib 29 | pm_to_blib 30 | *.bak 31 | PerlPowerTools-* 32 | MANIFEST [23456] 33 | Changes [23456] 34 | Makefile [23456] 35 | *.icloud 36 | *.icloud 37 | 38 | MANIFEST*[123456789] 39 | Changes*[123456789] 40 | 41 | /test/ 42 | output.txt 43 | .DS_Store 44 | -------------------------------------------------------------------------------- /.perltidyrc: -------------------------------------------------------------------------------- 1 | -l=120 # Max line width is 120 cols 2 | -i=4 # Indent level is 4 cols 3 | -ci=4 # Continuation indent is 4 cols 4 | -et=4 # four space tabs 5 | 6 | -b # Write the file inline and create a .bak file 7 | -se # Errors to STDERR 8 | 9 | -vt=2 # Maximal vertical tightness 10 | -cti=1 # No extra indentation for closing brackets 11 | -pt=1 # Medium parenthesis tightness 12 | -bt=1 # Medium brace tightness 13 | -sbt=1 # Medium square bracket tightness 14 | -bbt=1 # Medium block brace tightness 15 | -nsfs # No space before semicolons 16 | -nolq # Don't outdent long quoted strings 17 | -nsbl # opening block brace on same line 18 | -icb # indent closing brace 19 | -------------------------------------------------------------------------------- /.releaserc: -------------------------------------------------------------------------------- 1 | cpan_user BRIANDFOY 2 | skip_kwalitee 1 3 | skip_prereqs 1 4 | -------------------------------------------------------------------------------- /CNAME: -------------------------------------------------------------------------------- 1 | perlpowertools.com 2 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to this project 2 | 3 | PerlPowerTools is a collection of scripts that reproduce the behavior 4 | of standard unix tools so you can use the same commands on non-Unix 5 | systems. 6 | 7 | This is designed as a drop-in installation, so comes with some unusual 8 | requirements. 9 | 10 | * Works on Perl v5.8 11 | * Uses only core modules (with very few exceptions) 12 | * Uses the Artistic License 2 13 | * Works on Windows 14 | 15 | Many of these scripts were written around the time of Perl v5.6, so the 16 | style and idioms you may encounter can be quite archaic. Feel free to 17 | update those, but only up to v5.8. 18 | 19 | Before you go crazy with huge changes, make some small pull requests to 20 | check that we want to change the tools in that way. Pull requests that 21 | have one logical change are better. 22 | 23 | There's a Perl::Critic test is *xt/perlcritic.t*. Your new code or fixes 24 | should at least pass all those checks. Many are disabled because they are 25 | a problem across the code base (and there aren't tests). 26 | 27 | ## Adding a new program 28 | 29 | New programs follow the same general rules, but there are some extra 30 | things you need to do: 31 | 32 | * Add the program name to *lib/PerlPowerTools.pm* 33 | * Add the program to the lists in *index.html*, *ru/index.html*, and *uk/index.html* in the gh-pages branch 34 | * Run `make manifest` and check that it adds your new command and tests 35 | 36 | For new programs, include tests with as high a coverage as you can 37 | stand. Each program should have its own directory under *t/*. 38 | 39 | 40 | ## Pull requests 41 | 42 | Good pull requests - patches, improvements, new features - are a fantastic 43 | help. They should remain focused in scope and avoid containing unrelated 44 | commits. 45 | 46 | **Please ask first** before embarking on any significant pull request (e.g. 47 | implementing features, refactoring code, porting to a different language), 48 | otherwise you risk spending a lot of time working on something that the 49 | project's developers might not want to merge into the project. 50 | 51 | Please adhere to the coding conventions used throughout a project (indentation, 52 | accurate comments, etc.) and any other requirements (such as test coverage). 53 | 54 | Follow this process if you'd like your work considered for inclusion in the 55 | project: 56 | 57 | 1. [Fork](http://help.github.com/fork-a-repo/) the project, clone your fork, 58 | and configure the remotes: 59 | 60 | ```bash 61 | # Clone your fork of the repo into the current directory 62 | git clone https://github.com// 63 | # Navigate to the newly cloned directory 64 | cd 65 | # Assign the original repo to a remote called "upstream" 66 | git remote add upstream https://github.com// 67 | ``` 68 | 69 | 2. If you cloned a while ago, get the latest changes from upstream: 70 | 71 | ```bash 72 | git checkout 73 | git pull upstream 74 | ``` 75 | 76 | 3. Create a new topic branch (off the main project development branch) to 77 | contain your feature, change, or fix: 78 | 79 | ```bash 80 | git checkout -b 81 | ``` 82 | 83 | 4. Commit your changes in logical chunks. Please make your git commit message detailed and specific 84 | or your code is unlikely be merged into the main project. Use Git's 85 | [interactive rebase](https://help.github.com/articles/interactive-rebase) 86 | feature to tidy up your commits before making them public. 87 | 88 | 5. Locally merge (or rebase) the upstream development branch into your topic branch: 89 | 90 | ```bash 91 | git pull [--rebase] upstream 92 | ``` 93 | 94 | 6. Push your topic branch up to your fork: 95 | 96 | ```bash 97 | git push origin 98 | ``` 99 | 100 | 7. [Open a Pull Request](https://help.github.com/articles/using-pull-requests/) 101 | with a clear title and description. 102 | 103 | **IMPORTANT**: By submitting a patch, you agree to allow the project owner to 104 | license your work under the same license as that used by the project. 105 | -------------------------------------------------------------------------------- /INSTALL.SKIP: -------------------------------------------------------------------------------- 1 | README\.pod 2 | README.* 3 | 4 | # things that might be in local directories after fooling 5 | # around with them 6 | \.DS_Store 7 | -------------------------------------------------------------------------------- /LICENSE-BSD2: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 1999-2023, The Perl Power Tools Porject 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 16 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 17 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 19 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 21 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 22 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 23 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 24 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | bin/addbib 2 | bin/apply 3 | bin/ar 4 | bin/arch 5 | bin/arithmetic 6 | bin/asa 7 | bin/awk 8 | bin/banner 9 | bin/base64 10 | bin/basename 11 | bin/bc 12 | bin/bcd 13 | bin/cal 14 | bin/cat 15 | bin/chgrp 16 | bin/ching 17 | bin/chmod 18 | bin/chown 19 | bin/clear 20 | bin/cmp 21 | bin/col 22 | bin/colrm 23 | bin/comm 24 | bin/cp 25 | bin/cut 26 | bin/date 27 | bin/dc 28 | bin/deroff 29 | bin/diff 30 | bin/dirname 31 | bin/du 32 | bin/echo 33 | bin/ed 34 | bin/env 35 | bin/expand 36 | bin/expr 37 | bin/factor 38 | bin/false 39 | bin/file 40 | bin/find 41 | bin/fish 42 | bin/fmt 43 | bin/fold 44 | bin/fortune 45 | bin/from 46 | bin/glob 47 | bin/grep 48 | bin/hangman 49 | bin/head 50 | bin/hexdump 51 | bin/id 52 | bin/install 53 | bin/join 54 | bin/kill 55 | bin/ln 56 | bin/lock 57 | bin/look 58 | bin/ls 59 | bin/mail 60 | bin/maze 61 | bin/mimedecode 62 | bin/mkdir 63 | bin/mkfifo 64 | bin/moo 65 | bin/morse 66 | bin/nl 67 | bin/od 68 | bin/par 69 | bin/paste 70 | bin/patch 71 | bin/pig 72 | bin/ping 73 | bin/pom 74 | bin/ppt 75 | bin/pr 76 | bin/primes 77 | bin/printenv 78 | bin/printf 79 | bin/pwd 80 | bin/rain 81 | bin/random 82 | bin/rev 83 | bin/rm 84 | bin/rmdir 85 | bin/robots 86 | bin/rot13 87 | bin/seq 88 | bin/shar 89 | bin/sleep 90 | bin/sort 91 | bin/spell 92 | bin/split 93 | bin/strings 94 | bin/sum 95 | bin/tac 96 | bin/tail 97 | bin/tar 98 | bin/tee 99 | bin/test 100 | bin/time 101 | bin/touch 102 | bin/tr 103 | bin/true 104 | bin/tsort 105 | bin/tty 106 | bin/uname 107 | bin/unexpand 108 | bin/uniq 109 | bin/units 110 | bin/unlink 111 | bin/unpar 112 | bin/unshar 113 | bin/uudecode 114 | bin/uuencode 115 | bin/wc 116 | bin/what 117 | bin/which 118 | bin/whoami 119 | bin/whois 120 | bin/words 121 | bin/wump 122 | bin/xargs 123 | bin/yes 124 | Changes 125 | CONTRIBUTING.md 126 | INSTALL.SKIP 127 | lib/PerlPowerTools.pm 128 | lib/PerlPowerTools/SymbolicMode.pm 129 | lib/ppt.pm 130 | LICENSE-ARTISTIC2 131 | LICENSE-BSD2 132 | LICENSE-GPL2 133 | Makefile.PL 134 | MANIFEST 135 | MANIFEST.SKIP 136 | META.yml 137 | README.pod 138 | t/000.basic.t 139 | t/910.meta.t 140 | t/990.pod.t 141 | t/bc/input.t 142 | t/cat/cat.t 143 | t/cp/gh-115-copy-into-dir.t 144 | t/cut/cut.t 145 | t/data/cat/cat-n-1.txt 146 | t/data/nl/nl.txt 147 | t/data/od/ascii.txt 148 | t/data/rev/reverse-this.txt 149 | t/data/sort/ints1.txt 150 | t/data/sort/letters1.txt 151 | t/data/sort/three-words.txt 152 | t/date/date.t 153 | t/echo/echo.t 154 | t/factor/factor.t 155 | t/false/false.t 156 | t/find/find.t 157 | t/glob/glob.t 158 | t/lib/common.pl 159 | t/lib/utils.pm 160 | t/ls/ls.t 161 | t/mimedecode/000.basic.t 162 | t/nl/nl.t 163 | t/od/od.t 164 | t/rev/rev.t 165 | t/rm/process_options.t 166 | t/rm/run.t 167 | t/robots/000.basic.t 168 | t/rot13/rot13.t 169 | t/seq/seq.t 170 | t/sort/sort.t 171 | t/true/true.t 172 | t/units/units.t 173 | t/uudecode/uudecode.t 174 | xt/changes.t 175 | xt/perlcritic.t 176 | xt/perlcriticrc 177 | xt/pod.t 178 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | 2 | #!start included /usr/local/perls/perl-5.20.0/lib/5.20.0/ExtUtils/MANIFEST.SKIP 3 | # Avoid version control files. 4 | \bRCS\b 5 | \bCVS\b 6 | \bSCCS\b 7 | ,v$ 8 | \B\.svn\b 9 | \B\.git\b 10 | \B\.gitignore\b 11 | \b_darcs\b 12 | \B\.cvsignore$ 13 | 14 | # Avoid VMS specific MakeMaker generated files 15 | \bDescrip.MMS$ 16 | \bDESCRIP.MMS$ 17 | \bdescrip.mms$ 18 | 19 | # Avoid Makemaker generated and utility files. 20 | \bMANIFEST\.bak 21 | \bMakefile$ 22 | \bblib/ 23 | \bMakeMaker-\d 24 | \bpm_to_blib\.ts$ 25 | \bpm_to_blib$ 26 | \bblibdirs\.ts$ # 6.18 through 6.25 generated this 27 | 28 | # Avoid Module::Build generated and utility files. 29 | \bBuild$ 30 | \b_build/ 31 | \bBuild.bat$ 32 | \bBuild.COM$ 33 | \bBUILD.COM$ 34 | \bbuild.com$ 35 | 36 | # Avoid temp and backup files. 37 | ~$ 38 | \.old$ 39 | \#$ 40 | \b\.# 41 | \.bak$ 42 | \.tmp$ 43 | \.# 44 | \.rej$ 45 | 46 | # Avoid OS-specific files/dirs 47 | # Mac OSX metadata 48 | \B\.DS_Store 49 | # Mac OSX SMB mount metadata files 50 | \B\._ 51 | 52 | # Avoid Devel::Cover and Devel::CoverX::Covered files. 53 | \bcover_db\b 54 | \bcovered\b 55 | 56 | # Avoid MYMETA files 57 | ^MYMETA\. 58 | #!end included /usr/local/perls/perl-5.20.0/lib/5.20.0/ExtUtils/MANIFEST.SKIP 59 | 60 | \.?appveyor.yml 61 | \.releaserc 62 | \.lwpcookies 63 | 64 | util/create_tool_list 65 | CNAME 66 | ^data/ 67 | 68 | # weird iCloud file versioning 69 | pm_to_blib\s 70 | MANIFEST\s 71 | Changes\s 72 | Makefile\s 73 | MYMETA\s 74 | \B\.github/ 75 | \bTODO\b 76 | 77 | # This program isn't working and has Perl 4 dependencies 78 | # https://github.com/briandfoy/PerlPowerTools/issues/92 79 | bin/man 80 | # Make and its dependencies are uncertain 81 | # https://github.com/graphviz-perl/Graph/issues/17 82 | bin/make 83 | bin/pmake 84 | \bMANIFEST\s\d 85 | \bChanges\s\d 86 | \.icloud$ 87 | \A\.github\b 88 | 89 | util/ 90 | 91 | output.txt 92 | \.gitattributes\b 93 | 94 | bin/perldoc 95 | bin/perlpowertools 96 | packed/ 97 | packer/ 98 | 99 | PROGRAMMING_STYLE.md 100 | .perltidyrc 101 | .token 102 | -------------------------------------------------------------------------------- /META.yml: -------------------------------------------------------------------------------- 1 | # http://module-build.sourceforge.net/META-spec.html 2 | #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# 3 | name: ppt 4 | version: 0.14 5 | version_from: README 6 | installdirs: site 7 | requires: 8 | 9 | distribution_type: module 10 | generated_by: ExtUtils::MakeMaker version 6.17 11 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | === find 2 | shells out to find2perl, which might be removed from perl. 3 | 4 | === Things that use system() and need special attention 5 | addbib: or die "system '$1 $database' failed: $?"; 6 | addbib: system("$1 $database") == 0 7 | 8 | apply: system $new_command; # Reinterpreted by the shell! 9 | apply: system $command, splice @ARGV, 0, $argc; 10 | apply: system $command; 11 | 12 | 13 | awk:system 'a2p', @nargs; 14 | 15 | find:system 'find2perl', @ARGV; 16 | 17 | install: if (system "strip", $path) { 18 | install: if (system "cmp", "-s", $file, $targ) { 19 | 20 | man: if (system $command) { 21 | 22 | mail: /\!/ && do { system($arg); last SWITCH; }; 23 | mail: system("$ENV{VISUAL} /tmp/ppt_mail$$"); 24 | mail: system("/bin/sh"); # For now. :-) 25 | mail: system("$ENV{VISUAL} /tmp/ppt_mail$$"); 26 | mail: system("$1"); 27 | 28 | unshar: system '.r' if $ans =~ /^y/i; 29 | 30 | time:$rc = system(@ARGV); 31 | 32 | xargs: system(@run) == 0 or exit($? >> 8); 33 | -------------------------------------------------------------------------------- /bin/arch: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: arch 6 | Description: display system machine type 7 | Author: Theo Van Dinter, felicity@kluge.net 8 | License: 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | use strict; 15 | 16 | use File::Basename qw(basename); 17 | use Getopt::Std qw(getopts); 18 | use POSIX qw(uname); 19 | 20 | use constant EX_SUCCESS => 0; 21 | use constant EX_FAILURE => 1; 22 | 23 | my $Program = basename($0); 24 | 25 | my %opt; 26 | getopts('k', \%opt) or usage(); 27 | usage() if @ARGV; 28 | 29 | # system ... (uname -s) 30 | # arch ... (uname -m) 31 | my ($system, $arch) = (uname())[0,4]; 32 | 33 | # sun3.* -> sun3, sun4.* -> sun4, etc. SunOS hooey. 34 | # looks like `uname -m` eq `arch -k` on suns ... 35 | unless ($opt{'k'}) { 36 | $arch =~ s/^(sun\d+).*$/$1/; 37 | } 38 | 39 | $arch = "$system.$arch" if ( $system eq "OpenBSD" ); # OpenBSD hooey. 40 | print "$arch\n"; 41 | exit EX_SUCCESS; 42 | 43 | sub usage { 44 | warn "usage: $Program [-k]\n"; 45 | exit EX_FAILURE; 46 | } 47 | 48 | =head1 NAME 49 | 50 | arch - display system machine type 51 | 52 | =head1 SYNOPSIS 53 | 54 | B [ C<-k> ] 55 | 56 | =head1 DESCRIPTION 57 | 58 | arch displays the current system architecture type. It tends to be 59 | equivilent to C (except on SunOS platforms, see B). 60 | 61 | =head1 OPTIONS 62 | 63 | C<-k> Displays kernel architecture on SunOS platforms. 64 | 65 | =head1 NOTES 66 | 67 | SunOS tends to differentiate between kernel and system architecture. I will return kernel architecture. System architecture is the same 69 | information except it doesn't include the trailing alpha chars. I.e.: 70 | 'sun4m' (kernel) = 'sun4' (system), 'sun3x' = 'sun3', etc, etc. 71 | 72 | =head1 HISTORY 73 | 74 | Perl version rewritten for the Perl Power Tools project from the 75 | description of the arch program in OpenBSD. 76 | 77 | =head1 AUTHOR 78 | 79 | Theo Van Dinter (felicity@kluge.net) 80 | 81 | =head1 SEE ALSO 82 | 83 | uname(1) uname(2) machine(1) 84 | -------------------------------------------------------------------------------- /bin/asa: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: asa 6 | Description: interpret ASA/FORTRAN carriage-controls 7 | Author: Jeffrey S. Haemer 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | use File::Basename qw(basename); 18 | 19 | use constant EX_SUCCESS => 0; 20 | use constant EX_FAILURE => 1; 21 | 22 | my $Program = basename($0); 23 | 24 | if (grep /\A\-/, @ARGV) { 25 | warn "usage: $Program [file ...]\n"; 26 | exit EX_FAILURE; 27 | } 28 | my $rc = EX_SUCCESS; 29 | foreach my $file (@ARGV) { 30 | next if (-d $file); 31 | my $fh; 32 | unless (open $fh, '<', $file) { 33 | warn "$Program: Can't open '$file': $!\n"; 34 | $rc = EX_FAILURE; 35 | next; 36 | } 37 | run_file($fh); 38 | 39 | unless (close $fh) { 40 | warn "$Program: Can't close '$file': $!\n"; 41 | $rc = EX_FAILURE; 42 | } 43 | } 44 | unless (@ARGV) { 45 | run_file(*STDIN); 46 | } 47 | exit $rc; 48 | 49 | sub run_file { 50 | my $fh = shift; 51 | 52 | my %prefix = ( 53 | '1' => "\f", 54 | '+' => "\r", 55 | '0' => "\n\n", 56 | '-' => "\n\n\n", 57 | ); 58 | while (<$fh>) { 59 | chomp; 60 | if (!length($_)) { 61 | print "\n"; 62 | next; 63 | } 64 | my $c = substr $_, 0, 1; 65 | $_ = substr $_, 1; 66 | my $p = exists $prefix{$c} ? $prefix{$c} : "\n"; 67 | print $p, $_; 68 | } 69 | } 70 | 71 | =head1 NAME 72 | 73 | asa - interpret ASA/FORTRAN carriage-controls 74 | 75 | =head1 SYNOPSIS 76 | 77 | asa [I ...] 78 | 79 | =head1 DESCRIPTION 80 | 81 | =over 2 82 | 83 | Traditional FORTRAN programs put carriage-control characters 84 | in the first columns of their output, 85 | which were interpreted by older lineprinters 86 | according to the ASA vertical format control standard. 87 | (ASA was the American Standards Association -- now ANSI.) 88 | 89 | Under this standard, the first character of each printable record (line) 90 | determines vertical spacing, as follows: 91 | 92 | =over 2 93 | 94 | I carriage return 95 | 0 two carriage returns 96 | 1 Formfeed 97 | + overprint 98 | - three carriage returns (IBM extension) 99 | 100 | =back 101 | 102 | All other characters are discarded, and empty lines behave as though 103 | they have a leading blank. 104 | 105 | B interprets these characters. 106 | 107 | =back 108 | 109 | =head1 EXIT VALUES 110 | 111 | =over 2 112 | 113 | 0 normal exit 114 | 115 | 1 inability to write on stdout or to read an input file 116 | 117 | 2 bad argument 118 | 119 | Exit status values chosen from MKS toolkit. 120 | 121 | =back 122 | 123 | =head1 AUTHOR 124 | 125 | Jeffrey S. Haemer 126 | 127 | =head1 BUGS 128 | 129 | Currently, B just looks at the readability of its input files 130 | at startup time. It should really do it a file at a time, 131 | but that makes the code look gross. 132 | 133 | The carriage-control '-' is an IBM extension. 134 | Perhaps the default should ignore it 135 | and there should be a '-i' option to interpret it. 136 | 137 | =head1 SEE ALSO 138 | 139 | Communications of the ACM, Vol 7, No. 10, p. 606, October 140 | 1964. 141 | 142 | NWG/RFC 189, Appendix C 143 | 144 | =cut 145 | -------------------------------------------------------------------------------- /bin/base64: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =encoding utf8 4 | 5 | =begin metadata 6 | 7 | Name: base64 8 | Description: encode and decode base64 data 9 | Author: Michael Mikonos 10 | License: artistic2 11 | 12 | =end metadata 13 | 14 | =cut 15 | 16 | use strict; 17 | use warnings; 18 | 19 | use constant EX_SUCCESS => 0; 20 | use constant EX_FAILURE => 1; 21 | 22 | use File::Basename qw(basename); 23 | use Getopt::Std qw(getopts); 24 | use MIME::Base64 qw(decode_base64 encode_base64); 25 | 26 | my $VERSION = '1.0'; 27 | 28 | my $Program = basename($0); 29 | 30 | my (%opt, $bufsz, $in, $out); 31 | getopts('do:v', \%opt) or usage(); 32 | if (scalar(@ARGV) > 1) { 33 | warn "$Program: too many arguments\n"; 34 | usage(); 35 | } 36 | if ($opt{'v'}) { 37 | print "$Program version $VERSION\n"; 38 | exit EX_SUCCESS; 39 | } 40 | $bufsz = $opt{'d'} ? 76 : 57; 41 | $bufsz *= 20; 42 | if (defined $opt{'o'}) { 43 | unless (open $out, '>', $opt{'o'}) { 44 | warn "$Program: cannot open '$opt{o}': $!\n"; 45 | exit EX_FAILURE; 46 | } 47 | } else { 48 | $out = *STDOUT; 49 | } 50 | if (defined $ARGV[0] && $ARGV[0] ne '-') { 51 | if (-d $ARGV[0]) { 52 | warn "$Program: '$ARGV[0]' is a directory\n"; 53 | exit EX_FAILURE; 54 | } 55 | unless (open $in, '<', $ARGV[0]) { 56 | warn "$Program: cannot open '$ARGV[0]': $!\n"; 57 | exit EX_FAILURE; 58 | } 59 | } else { 60 | $in = *STDIN; 61 | } 62 | 63 | $opt{'d'} ? decode() : encode(); 64 | unless (close $in) { 65 | warn "$Program: failed to close input: $!\n"; 66 | exit EX_FAILURE; 67 | } 68 | unless (close $out) { 69 | warn "$Program: failed to close output: $!\n"; 70 | exit EX_FAILURE; 71 | } 72 | exit EX_SUCCESS; 73 | 74 | sub decode { 75 | my $buf = ''; 76 | while (readline $in) { 77 | s/\s//g; 78 | if (m/[^A-Za-z0-9\+\/\=]/) { 79 | warn "$Program: bad input\n"; 80 | exit EX_FAILURE; 81 | } 82 | $buf .= $_; 83 | if (length($buf) >= $bufsz) { 84 | my $chunk = substr($buf, 0, $bufsz); 85 | print {$out} decode_base64($chunk); 86 | $buf = substr($buf, $bufsz); 87 | } 88 | } 89 | if (length $buf) { 90 | print {$out} decode_base64($buf); # end chunk 91 | } 92 | } 93 | 94 | sub encode { 95 | my $buf; 96 | while (read $in, $buf, $bufsz) { 97 | print {$out} encode_base64($buf); 98 | } 99 | } 100 | 101 | sub usage { 102 | warn "usage: $Program [-dv] [-o FILE] [FILE]\n"; 103 | exit EX_FAILURE; 104 | } 105 | 106 | __END__ 107 | 108 | =pod 109 | 110 | =head1 NAME 111 | 112 | base64 - encode and decode base64 data 113 | 114 | =head1 SYNOPSIS 115 | 116 | base64 [-dv] [-o FILE] [FILE] 117 | 118 | =head1 DESCRIPTION 119 | 120 | When encoding (the default mode), a binary file 121 | is read and a base64 format file is created. 122 | If no input file argument is provided, or file is '-', 123 | stdin will be used. 124 | The base64 output contains 76 characters per line. 125 | Output is written to stdout by default. 126 | 127 | When decoding, the input file is expected to contain 128 | only valid base64 characters (alphanumeric, '+', '/' and '='). 129 | Spaces are ignored when decoding. Selecting a binary file 130 | as input will result in an error. 131 | 132 | =head2 OPTIONS 133 | 134 | The following options are available: 135 | 136 | =over 4 137 | 138 | =item -d 139 | 140 | Decode data 141 | 142 | =item -o FILE 143 | 144 | Write output to the specified FILE 145 | 146 | =item -v 147 | 148 | Print version number and exit 149 | 150 | =back 151 | 152 | =head1 BUGS 153 | 154 | No option exists for wrapping encoded base64 output at different 155 | column widths. 156 | 157 | It might be desirable to ignore unrecognised input characters when 158 | decoding. This version of base64 has no option for relaxing the 159 | input validation. 160 | 161 | =head1 AUTHOR 162 | 163 | Written by Michael Mikonos. 164 | 165 | =head1 COPYRIGHT 166 | 167 | Copyright (c) 2023 Michael Mikonos. 168 | 169 | This code is licensed under the Artistic License 2. 170 | -------------------------------------------------------------------------------- /bin/basename: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: basename 6 | Description: print the basename of a file 7 | Author: Abigail, perlpowertools@abigail.be 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | use File::Basename qw(basename fileparse); 18 | use Getopt::Std qw(getopts); 19 | 20 | my $Program = basename($0); 21 | our $VERSION = '1.5'; 22 | 23 | getopts('') or usage(); 24 | my $path = shift; 25 | usage() unless defined $path; 26 | my $suffix = shift; 27 | usage() if @ARGV; 28 | if (!length($path)) { 29 | print "\n"; 30 | exit; 31 | } 32 | $path =~ s/\/+/\//g; # "///" -> "/" 33 | if ($path eq '/') { 34 | print "/\n"; 35 | exit; 36 | } 37 | $path =~ s/\/\Z//; # "a/" -> "a" 38 | my @parsed = fileparse($path); 39 | my $name = shift @parsed; 40 | if (defined $suffix) { 41 | my $i = rindex $name, $suffix; 42 | my $oklen = length($name) == length($suffix) + $i; 43 | if ($i > 0 && $oklen) { 44 | $name = substr $name, 0, $i; 45 | } 46 | } 47 | print $name, "\n"; 48 | exit 0; 49 | 50 | sub VERSION_MESSAGE { 51 | print "$Program version $VERSION\n"; 52 | exit 0; 53 | } 54 | 55 | sub usage { 56 | warn "usage: $Program string [suffix]\n"; 57 | exit 1; 58 | } 59 | 60 | __END__ 61 | 62 | =pod 63 | 64 | =head1 NAME 65 | 66 | basename - remove directory and suffix from filenames 67 | 68 | =head1 SYNOPSIS 69 | 70 | basename string [suffix] 71 | 72 | =head1 DESCRIPTION 73 | 74 | I prints the file component of a path. A second argument to 75 | I is interpreted as a suffix to remove from the file. 76 | It is not considered an error if the given suffix does not match the string. 77 | 78 | =head2 OPTIONS 79 | 80 | I does not accept any options. 81 | 82 | =head1 ENVIRONMENT 83 | 84 | The working of I is not influenced by any environment variables. 85 | 86 | =head1 BUGS 87 | 88 | I has no known bugs. 89 | 90 | =head1 STANDARDS 91 | 92 | This I implementation is compliant with the B 93 | specification, also known as B. 94 | 95 | This I implementation is compatible with the 96 | B implementation. 97 | 98 | =head1 AUTHOR 99 | 100 | The Perl implementation of I was written by Abigail, 101 | I. 102 | 103 | =head1 COPYRIGHT and LICENSE 104 | 105 | This program is copyright by Abigail 1999. 106 | 107 | This program is free and open software. You may use, copy, modify, distribute 108 | and sell this program (and any modified variants) in any way you wish, 109 | provided you do not restrict others to do the same. 110 | 111 | =cut 112 | 113 | -------------------------------------------------------------------------------- /bin/clear: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: clear 6 | Description: clear the screen 7 | Author: Jeffrey S. Haemer 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | use strict; 15 | 16 | use Term::Cap; 17 | 18 | my $cl = ""; 19 | eval { 20 | my $terminal = Term::Cap->Tgetent; 21 | $terminal->Trequire("cl"); 22 | $cl = $terminal->Tputs('cl', 1); 23 | }; 24 | 25 | if ($cl eq "" && $^O eq 'MSWin32') { 26 | system 'cls'; 27 | } else { 28 | print $cl; 29 | } 30 | 31 | 32 | =head1 NAME 33 | 34 | clear - clear the screen 35 | 36 | =head1 SYNOPSIS 37 | 38 | clear 39 | 40 | =head1 DESCRIPTION 41 | 42 | =over 2 43 | 44 | Look in the termcap database, find the character to clear the screen, 45 | and emit it. 46 | 47 | This is a direct lift from Section 15.7, B, from 48 | I, with C substituted for C. 49 | 50 | =back 51 | 52 | =head1 TYPIST 53 | 54 | Jeffrey S. Haemer 55 | 56 | =head1 BUGS 57 | 58 | B should probably take an argument, like B, that will 59 | let users send arbitrary termcap sequences, with C as the default. 60 | 61 | =head1 SEE ALSO 62 | 63 | Term::Cap(3) 64 | 65 | =cut 66 | -------------------------------------------------------------------------------- /bin/colrm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: colrm 6 | Description: remove columns from a file 7 | Author: Jeffrey S. Haemer 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | use File::Basename qw(basename); 18 | 19 | use constant EX_SUCCESS => 0; 20 | use constant EX_FAILURE => 1; 21 | 22 | my $Program = basename($0); 23 | 24 | if (@ARGV > 2) { 25 | warn "usage: $Program [startcol [endcol]]\n"; 26 | exit EX_FAILURE; 27 | } elsif (@ARGV == 0) { 28 | print while(<>); 29 | } elsif (@ARGV == 1) { 30 | my $startcol = getarg(); 31 | while (my $line = <>) { 32 | chomp $line; 33 | my $len = length $line; 34 | if ($startcol > $len) { 35 | print $line; 36 | } else { 37 | print substr $line, 0, $startcol - 1; 38 | } 39 | print "\n"; 40 | } 41 | } elsif (@ARGV == 2) { 42 | my $startcol = getarg(); 43 | my $endcol = getarg(); 44 | if ($startcol > $endcol) { 45 | warn "$Program: bad range: $startcol,$endcol\n"; 46 | exit EX_FAILURE; 47 | } 48 | while (my $line = <>) { 49 | chomp $line; 50 | my $len = length $line; 51 | if ($startcol > $len) { 52 | print $line; 53 | } else { 54 | print substr $line, 0, $startcol - 1; 55 | print substr $line, $endcol; 56 | } 57 | print "\n"; 58 | } 59 | } 60 | exit EX_SUCCESS; 61 | 62 | sub getarg { 63 | my $n = shift @ARGV; 64 | if (!defined($n)) { 65 | warn "$Program: missing argument\n"; 66 | exit EX_FAILURE; 67 | } 68 | if ($n =~ m/[^0-9]/ || $n == 0) { 69 | warn "$Program: invalid column number '$n'\n"; 70 | exit EX_FAILURE; 71 | } 72 | return $n; 73 | } 74 | 75 | 76 | =head1 NAME 77 | 78 | colrm - remove columns from a file 79 | 80 | =head1 SYNOPSIS 81 | 82 | colrm [startcol [endcol]] 83 | 84 | =head1 DESCRIPTION 85 | 86 | B removes the named columns from each line of its standard input 87 | (one column = one character). 88 | Column numbering starts at 1, not 0. 89 | 90 | If a only I is provided, removes all columns from I 91 | rightwards. 92 | 93 | If both I and I are provided, removes all columns from 94 | I to I, inclusive. 95 | 96 | If neither is provided, acts just like B. 97 | 98 | =head1 OPTIONS AND ARGUMENTS 99 | 100 | =over 2 101 | 102 | =item I 103 | 104 | The first column to remove. 105 | 106 | =item I 107 | 108 | The last column to remove. 109 | 110 | =back 111 | 112 | =head1 AUTHOR 113 | 114 | Jeffrey S. Haemer 115 | 116 | =head1 BUGS 117 | 118 | Lacks the special-case handling of backspace and tab added in some 119 | other versions. Acts, instead, like the simpler Linux and SunOS versions. 120 | 121 | =head1 SEE ALSO 122 | 123 | awk(1) 124 | -------------------------------------------------------------------------------- /bin/comm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: comm 6 | Description: select or reject lines common to two files 7 | Author: Mark-Jason Dominus, mjd-perl-comm@plover.comm 8 | License: public domain 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # 16 | # comm 17 | # 18 | # 1999 M-J. Dominus (mjd-perl-comm@plover.com) 19 | # Public domain. 20 | # 21 | 22 | use strict; 23 | 24 | use File::Basename qw(basename); 25 | use Getopt::Std qw(getopts); 26 | 27 | use constant EX_SUCCESS => 0; 28 | use constant EX_FAILURE => 1; 29 | 30 | my $Program = basename($0); 31 | 32 | my %opt; 33 | getopts('123', \%opt) or usage(); 34 | usage() if (@ARGV != 2); 35 | my @COL = (undef, !$opt{'1'}, !$opt{'2'}, !$opt{'3'}); 36 | 37 | my ($f1, $f2); 38 | if ($ARGV[0] eq '-') { 39 | if ($ARGV[1] eq '-') { 40 | warn "$Program: only one file argument may be stdin\n"; 41 | exit EX_FAILURE; 42 | } 43 | $f1 = *STDIN; 44 | } else { 45 | if (-d $ARGV[0]) { 46 | warn "$Program: '$ARGV[0]' is a directory\n"; 47 | exit EX_FAILURE; 48 | } 49 | unless (open $f1, '<', $ARGV[0]) { 50 | warn "$Program: Couldn't open file '$ARGV[0]': $!\n"; 51 | exit EX_FAILURE; 52 | } 53 | } 54 | if ($ARGV[1] eq '-') { 55 | $f2 = *STDIN; 56 | } else { 57 | if (-d $ARGV[1]) { 58 | warn "$Program: '$ARGV[1]' is a directory\n"; 59 | exit EX_FAILURE; 60 | } 61 | unless (open $f2, '<', $ARGV[1]) { 62 | warn "$Program: Couldn't open file '$ARGV[1]': $!\n"; 63 | exit EX_FAILURE; 64 | } 65 | } 66 | 67 | my $r1 = <$f1>; 68 | my $r2 = <$f2>; 69 | 70 | while (defined $r1 && defined $r2) { 71 | if ($r1 eq $r2) { 72 | print "\t\t", $r1 if $COL[3]; 73 | $r1 = <$f1>; 74 | $r2 = <$f2>; 75 | } elsif ($r1 gt $r2) { 76 | print "\t", $r2 if $COL[2]; 77 | $r2 = <$f2>; 78 | } else { 79 | print $r1 if $COL[1]; 80 | $r1 = <$f1>; 81 | } 82 | } 83 | 84 | print $r1 if defined $r1 && $COL[1]; 85 | print "\t", $r2 if defined $r2 && $COL[2]; 86 | if ($COL[1]) { print while <$f1> } 87 | if ($COL[2]) { print "\t", $_ while <$f2> } 88 | 89 | close $f1; 90 | close $f2; 91 | exit EX_SUCCESS; 92 | 93 | sub usage { 94 | warn "usage: $Program [-123] file1 file2\n"; 95 | exit EX_FAILURE; 96 | } 97 | 98 | __END__ 99 | 100 | =encoding utf8 101 | 102 | =head1 NAME 103 | 104 | comm - select or reject lines common to two files 105 | -------------------------------------------------------------------------------- /bin/dirname: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: dirname 6 | Description: print the directory name of a path 7 | Author: Michael Mikonos 8 | Auhtor: Abigail, perlpowertools@abigail.be 9 | License: perl 10 | 11 | =end metadata 12 | 13 | =cut 14 | 15 | 16 | use strict; 17 | 18 | use File::Basename qw(basename dirname); 19 | use Getopt::Std qw(getopts); 20 | 21 | my $Program = basename($0); 22 | our $VERSION = '1.3'; 23 | 24 | getopts('') or usage(); 25 | usage() unless scalar(@ARGV) == 1; 26 | my $path = shift; 27 | my $dir = dirname($path); 28 | print $dir, "\n"; 29 | exit 0; 30 | 31 | sub VERSION_MESSAGE { 32 | print "$Program version $VERSION\n"; 33 | exit 0; 34 | } 35 | 36 | sub usage { 37 | warn "usage: $Program string\n"; 38 | exit 1; 39 | } 40 | 41 | __END__ 42 | 43 | =pod 44 | 45 | =head1 NAME 46 | 47 | dirname - print the directory name of a path 48 | 49 | =head1 SYNOPSIS 50 | 51 | dirname string 52 | 53 | =head1 DESCRIPTION 54 | 55 | I prints the directory component of a path. Everything starting 56 | from the last I (or whatever the path separator is on your OS) is 57 | deleted. 58 | 59 | =head2 OPTIONS 60 | 61 | =over 4 62 | 63 | =item * --version 64 | 65 | =back 66 | 67 | =head1 ENVIRONMENT 68 | 69 | The working of I is not influenced by any environment variables. 70 | 71 | =head1 BUGS 72 | 73 | I has no known bugs. 74 | 75 | =head1 STANDARDS 76 | 77 | This I implementation is compliant with the B 78 | specification, also known as B. 79 | 80 | This I implementation is compatible with the 81 | B implementation. 82 | 83 | =head1 AUTHOR 84 | 85 | This implementation of I was adapted by Michael Mikonos. 86 | 87 | The original version was written by Abigail, but the code was completely replaced. 88 | 89 | =head1 COPYRIGHT and LICENSE 90 | 91 | This program is copyright by Abigail, 1999, and Michael Mikonos, 2024. 92 | 93 | This program is free and open software. You may use, copy, modify, distribute 94 | and sell this program (and any modified variants) in any way you wish, 95 | provided you do not restrict others to do the same. 96 | 97 | =cut 98 | 99 | -------------------------------------------------------------------------------- /bin/echo: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: echo 6 | Description: echo arguments 7 | Author: Randy Yarger, randy.yarger@nextel.com 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | package PerlPowerTools::echo; 15 | 16 | use strict; 17 | 18 | our $VERSION = '1.3'; 19 | 20 | # run if called directly, indirectly, directly par-packed, undirectly par-packed 21 | __PACKAGE__->run( @ARGV ) if !caller() || caller(0) =~ /^(PerlPowerTools::Packed|PAR)$/ || caller(1) eq 'PAR'; 22 | 23 | sub run { 24 | my ( $self, @args ) = @_; 25 | 26 | my $N = 1; 27 | if (@args && $args[0] eq '-n') { 28 | $N = 0; 29 | shift @args; 30 | } 31 | 32 | print join ' ', @args; 33 | print "\n" if $N == 1; 34 | 35 | exit 0; 36 | } 37 | 38 | 1; 39 | 40 | __END__ 41 | 42 | =pod 43 | 44 | =head1 NAME 45 | 46 | echo - echo arguments 47 | 48 | =head1 SYNOPSIS 49 | 50 | echo [-n] [arguments...] 51 | 52 | =head1 DESCRIPTION 53 | 54 | echo prints the command line arguments separated by spaces. A newline is 55 | printed at the end unless the '-n' option is given. 56 | 57 | =head2 OPTIONS 58 | 59 | I accepts the following options: 60 | 61 | =over 4 62 | 63 | =item -n 64 | 65 | Do not print a newline after the arguments. 66 | 67 | =back 68 | 69 | =head1 ENVIRONMENT 70 | 71 | The working of I is not influenced by any environment variables. 72 | 73 | =head1 BUGS 74 | 75 | I has no known bugs. 76 | 77 | =head1 AUTHOR 78 | 79 | The Perl implementation of I 80 | was written by Randy Yarger, I. 81 | 82 | =head1 COPYRIGHT and LICENSE 83 | 84 | This program is copyright by Randy Yarger 1999. 85 | 86 | This program is free and open software. You may use, modify, distribute 87 | and sell this program (and any modified variants) in any way you wish, 88 | provided you do not restrict others to do the same. 89 | 90 | =cut 91 | -------------------------------------------------------------------------------- /bin/env: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: env 6 | Description: run a program in a modified environment 7 | Author: Matthew Bafford, dragons@scescape.net 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # Perl version of the env command. 16 | # Matthew Bafford 17 | # 2/28/1999 18 | 19 | use strict; 20 | 21 | use File::Basename qw(basename); 22 | 23 | my $Program = basename($0); 24 | 25 | while ( @ARGV && $ARGV[0] =~ /^-/ ) { 26 | my $arg = shift; 27 | 28 | if ( $arg eq '-i' ) { 29 | %ENV = (); 30 | } elsif ( $arg =~ /^-u(.*)/ ) { 31 | my $val = length $1 ? $1 : shift; 32 | if ($val =~ m/=/) { 33 | warn "$Program: bad unset argument: '$val'\n"; 34 | exit 2; 35 | } 36 | delete $ENV{$val}; 37 | } elsif ($arg eq '--') { 38 | last; 39 | } else { 40 | require Pod::Usage; 41 | Pod::Usage::pod2usage({ -exitval => 2, -verbose => 0 }); 42 | } 43 | } 44 | 45 | while ( @ARGV && $ARGV[0] =~ /=/ ) { 46 | my ( $name, $value ) = split /=/, shift, 2; 47 | 48 | $ENV{$name} = $value; 49 | } 50 | 51 | if ( !@ARGV ) { 52 | for ( keys %ENV ) { 53 | print "$_=$ENV{$_}\n"; 54 | } 55 | exit 0; 56 | } 57 | 58 | my $cmd = $ARGV[0]; 59 | unless (exec {$cmd} @ARGV) { 60 | warn "$Program: failed to exec '$cmd': $!\n"; 61 | exit 127; 62 | } 63 | 64 | __END__ 65 | 66 | =pod 67 | 68 | =head1 NAME 69 | 70 | env - Run a program in a modified environment 71 | 72 | =head1 SYNOPSIS 73 | 74 | env [B<-i>] [B<-u> name]... [name=value]... [command [args]...] 75 | 76 | =head1 DESCRIPTION 77 | 78 | I runs a command with the environment modified as specified 79 | by the command line. If no command is specified, I prints 80 | out the modified environment. 81 | 82 | =head2 OPTIONS 83 | 84 | I accepts the following options: 85 | 86 | =over 4 87 | 88 | =item B<-i> 89 | 90 | Clears the environment, passing only the values specified to the command. 91 | 92 | =item B<-u> I 93 | 94 | Clears the environment variable I if it exists. 95 | The value must not include the '=' character. 96 | This option may be repeated. 97 | 98 | =back 99 | 100 | =head1 DIAGNOSTICS 101 | 102 | If the command is invoked, the exit status of I will be the exit 103 | status of the command. Otherwise, I will return one of the following 104 | values: 105 | 106 | 0 env completed successfully. 107 | 1-125 An error occurred in env. 108 | 127 There was an error running the command specified. 109 | 110 | =head1 BUGS 111 | 112 | I has no known bugs. 113 | 114 | =head1 AUTHOR 115 | 116 | This Perl version of I was written by 117 | Matthew Bafford, I. 118 | 119 | =head1 COPYRIGHT and LICENSE 120 | 121 | This program is copyright (c) Matthew Bafford 1999. 122 | 123 | This program is free and open software. You may use, modify, distribute, 124 | and sell this program (and any modified variants) in any way you wish, 125 | provided you do not restrict others from doing the same. 126 | 127 | 128 | -------------------------------------------------------------------------------- /bin/expand: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: expand 6 | Description: convert tabs to spaces 7 | Author: Thierry Bezecourt, thbzcrt@worldnet.fr 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # 16 | # A Perl implementation of expand(1) and unexpand(1) for the Perl Power 17 | # Tools project by Thierry Bezecourt . 18 | # 19 | # I don't use Text::Tabs, because : 20 | # - it doesn't handle tags which are set at specified places on the line 21 | # - it doesn't recognize backspace characters 22 | # 23 | # Please see the pod documentation at the end of this file. 24 | # 25 | # 99/03/07 : first version 26 | # 27 | 28 | use strict; 29 | 30 | use File::Basename qw(basename); 31 | 32 | use constant EX_SUCCESS => 0; 33 | use constant EX_FAILURE => 1; 34 | 35 | my $Program = basename($0); 36 | 37 | my %line_desc; 38 | my $tabstop = 8; 39 | my @tabstops; 40 | 41 | while (@ARGV && $ARGV[0] =~ /\A\-(.+)/) { 42 | my $val = $1; 43 | if ($val eq '-') { 44 | shift @ARGV; 45 | last; 46 | } 47 | @tabstops = split /,/, $val; 48 | usage() if grep /\D/, @tabstops; # only integer arguments are allowed 49 | shift @ARGV; 50 | } 51 | 52 | # $tabstop is used only if multiple tab stops have not been defined 53 | if(scalar @tabstops == 0) { 54 | $tabstop = 8; 55 | } elsif(scalar @tabstops == 1) { 56 | $tabstop = $tabstops[0]; 57 | } else { 58 | my $howfar = 1; 59 | my %tabs = map { $_ => 1 } @tabstops; 60 | for (my $i = $tabstops[$#tabstops]-1; $i >= 0; $i--) { 61 | # how far is the $i-th column from the next tab 62 | $line_desc{$i} = $howfar; 63 | $howfar = 0 if defined $tabs{$i}; 64 | $howfar++; 65 | } 66 | } 67 | 68 | for my $file (@ARGV) { 69 | my $in; 70 | unless (open $in, '<', $file) { 71 | warn "$Program: couldn't open '$file' for reading: $!\n"; 72 | exit EX_FAILURE; 73 | } 74 | while (<$in>) { 75 | expand_line($_); 76 | } 77 | close $in; 78 | } 79 | unless (@ARGV) { 80 | while (<>) { 81 | expand_line($_); 82 | } 83 | } 84 | exit EX_SUCCESS; 85 | 86 | sub usage { 87 | warn "usage: $Program [-tabstop] [-tab1,tab2,...] [file ...]\n"; 88 | exit EX_FAILURE; 89 | } 90 | 91 | sub expand_line { 92 | my $line = shift; 93 | my $incr; 94 | my $curs = 0; 95 | 96 | for my $c (split //, $line) { 97 | if($c eq "\b") { # backspace 98 | print "\b"; 99 | $curs-- if $curs; 100 | } elsif($c eq "\t") { 101 | if(scalar @tabstops > 0) { 102 | if(defined($line_desc{$curs})) { 103 | $incr = $line_desc{$curs}; 104 | } else { # Jupiter, and beyond the infinite 105 | $incr = $tabstop; 106 | } 107 | } else { 108 | $incr = $curs%$tabstop ? ($tabstop - $curs%$tabstop) 109 | : $tabstop; 110 | } 111 | print ' ' x $incr; 112 | $curs += $incr; 113 | } else { 114 | print $c; 115 | $curs++; 116 | } 117 | } 118 | } 119 | 120 | __END__ 121 | 122 | =head1 NAME 123 | 124 | expand - convert tabs to spaces 125 | 126 | =head1 SYNOPSIS 127 | 128 | expand [B<-tabstop>] [B<-tab1,tab2,...>] [B ...] 129 | 130 | =head1 DESCRIPTION 131 | 132 | I processes the named files or the standard input writing the 133 | standard output with tabs changed into blanks. Backspace characters 134 | are preserved into the output and decrement the column count for tab 135 | calculations. I is useful for pre-processing character files 136 | (before sorting, looking at specific columns, etc.) that contain tabs. 137 | 138 | =head1 OPTIONS 139 | 140 | =over 4 141 | 142 | =item -tabstop 143 | 144 | Tabs are set B spaces apart instead of the default 8. 145 | 146 | =item -tab1,tab2,... 147 | 148 | Tabs are set at the specific column numbers B, B and so on. 149 | 150 | =back 151 | 152 | =head1 AUTHOR 153 | 154 | =for html 155 | The Perl implementation was written by Thierry Bézecourt for the 157 | Perl Power Tools project, 158 | March 1999. 159 | 160 | =for html 166 | 167 | This documentation comes from the BSD expand(1) man page. 168 | 169 | =head1 COPYRIGHT and LICENSE 170 | 171 | This program is free and open software. You may use, modify, distribute, 172 | and sell this program (and any modified variants) in any way you wish, 173 | provided you do not restrict others from doing the same. 174 | 175 | =cut 176 | 177 | -------------------------------------------------------------------------------- /bin/false: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: false 6 | Description: exit unsuccesfully 7 | Author: Abigail, perlpowertools@abigail.be 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | exit 1; 15 | 16 | __END__ 17 | 18 | =pod 19 | 20 | =head1 NAME 21 | 22 | false - Exit unsuccesfully 23 | 24 | =head1 SYNOPSIS 25 | 26 | false 27 | 28 | =head1 DESCRIPTION 29 | 30 | I exits unsuccesfully. 31 | 32 | =head1 ENVIRONMENT 33 | 34 | The working of I is not influenced by any environment variables. 35 | 36 | =head1 BUGS 37 | 38 | I has no known bugs. 39 | 40 | =head1 AUTHOR 41 | 42 | The Perl implementation of I 43 | was written by Abigail, I. 44 | 45 | =head1 COPYRIGHT and LICENSE 46 | 47 | This program is copyright by Abigail 1999. 48 | 49 | This program is free and open software. You may use, modify, distribute 50 | and sell this program (and any modified variants) in any way you wish, 51 | provided you do not restrict others to do the same. 52 | 53 | =cut 54 | 55 | -------------------------------------------------------------------------------- /bin/from: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: from 6 | Description: print names of those who have sent mail 7 | Author: Johan Vromans, jvromans@squirrel.nl 8 | License: public domain 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # This program requires perl version 3.0, patchlevel 4 or higher 16 | 17 | # Show messages from a Unix mailbox. With -n: shown message numbers also. 18 | # 19 | # Usage "from [-n] MAILBOX..." 20 | # 21 | # Don't forget: perl is a Practical Extract and Report Language! 22 | # 23 | # Copyright 1989,1993 Johan Vromans , no rights reserved. 24 | # Copyright 1993,1995 Johan Vromans , no rights reserved. 25 | # Copyright 1995,1996 Johan Vromans , no rights reserved. 26 | # Usage and redistribution is free and encouraged. 27 | 28 | # Default output format 29 | format = 30 | @<<<<<<<<<<< "@<<<<<<<<<<<<" @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 31 | $date, $from, $subj 32 | . 33 | 34 | # Output format when sequence numbers are requested 35 | format format_n = 36 | @>: @<<<<<<<<<<< "@<<<<<<<<<<<<" @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 37 | $seq, $date, $from, $subj 38 | . 39 | 40 | # Parse and stash away -n switch, if provided 41 | if ($#ARGV >= 0 && $ARGV[0] eq '-n') { 42 | shift (@ARGV); 43 | $~ = "format_n"; 44 | } 45 | 46 | # Use system mailbox if none was specified on the command line 47 | if ( $#ARGV < 0 ) { 48 | if ( ! ($user = getlogin)) { 49 | @a = getpwuid($<); 50 | $user = $a[0]; 51 | } 52 | if ( -r "/var/spool/mail/$user" ) { # Modern systems 53 | @ARGV = ("/var/spool/mail/$user"); 54 | } 55 | elsif ( -r "/usr/mail/$user" ) { # System V 56 | @ARGV = ("/usr/mail/$user"); 57 | } 58 | elsif ( -r "/usr/spool/mail" ) { # BSD 59 | @ARGV = ("/usr/spool/mail/$user"); 60 | } 61 | else { 62 | printf STDERR "No mail for $user.\n"; 63 | exit 1; 64 | } 65 | } 66 | 67 | $seq = 0; 68 | # Read through input file(s) 69 | while (<>) { 70 | 71 | # Look for a "From_" header (See RFC822 and associated documents). 72 | next unless /^From\s+(\S+)\s+.*(\w{3}\s+\d+\s+\d+:\d+)/; 73 | 74 | chop; 75 | $from = $1; 76 | $date = $2; 77 | if ( $date eq "" || $from eq "" ) { 78 | print STDERR "Possible garbage: $_\n"; 79 | next; 80 | } 81 | 82 | $seq++; 83 | # Get user name from uucp path 84 | $from = $1 if $from =~ /.*!(.+)/; 85 | 86 | # Now, scan for Subject or empty line 87 | $subj = ""; 88 | while ( <> ) { 89 | chop ($_); 90 | 91 | if ( /^$/ || /^From / ) { 92 | # force fall-though 93 | $subj = "" unless $subj; 94 | } 95 | else { 96 | $subj = $1 if /^Subject\s*:\s*(.*)/i; 97 | if ( /^From\s*:\s*/ ) { 98 | $_ = $'; 99 | if ( /\((.+)\)/i ) { $from = $1; } 100 | elsif ( /^\s*(.+)\s*<.+>/i ) { $from = $1; } 101 | elsif ( /^<.+>\s*(.+)/i ) { $from = $1; } 102 | } 103 | } 104 | 105 | # do we have enough info? 106 | if ( $from && $subj ) { 107 | # sorry, cannot use ^<<<... format (doesn't work?) 108 | substr($subj,47) = "..." if length($subj) > 50; 109 | write; 110 | last; 111 | } 112 | } 113 | } 114 | 115 | =encoding utf8 116 | 117 | =head1 NAME 118 | 119 | from - print names of those who have sent mail 120 | -------------------------------------------------------------------------------- /bin/hangman: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: hangman 6 | Description: the game hangman 7 | Author: Michael E. Schechter, mschechter@earthlink.net 8 | License: gpl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | srand(); 18 | my( $cont ) = "y"; 19 | my( %in_word, %guess, @guess, @word, @disp_word ); 20 | my( $letter, $word, $x, $num_wrong, $tot_letters, $num_corr ); 21 | 22 | while( $cont =~ /^y/io ) { 23 | ( %in_word, %guess, @disp_word ) = (); 24 | $word = &get_a_word(); 25 | @word = split( / */, $word ); 26 | for( $x = 0; $x <= $#word; $x++ ) { 27 | $disp_word[ $x ] = "_"; 28 | $in_word{ $word[ $x ] } = 1; 29 | } 30 | $tot_letters = scalar( keys( %in_word ) ); 31 | $num_wrong = 0; 32 | $num_corr = 0; 33 | &print_noose( $num_wrong, @disp_word ); 34 | while( ($num_wrong < 6) && ($num_corr < $tot_letters) ) { 35 | print "\nEnter a letter: "; 36 | $letter = ; 37 | exit unless defined $letter; 38 | chomp( $letter ); 39 | $letter = lc( $letter ); 40 | if( $letter =~ /^[a-z]$/o ) { 41 | if(! exists( $guess{ $letter } ) ) { 42 | $guess{ $letter } = 1; 43 | if(! exists( $in_word{ $letter } ) ) { 44 | $num_wrong++; 45 | } else { 46 | $num_corr++; 47 | for( $x = 0; $x <= $#word; $x++ ) { 48 | if( $word[ $x ] eq $letter ) { 49 | $disp_word[ $x ] = $letter; 50 | } 51 | } 52 | } 53 | } else { 54 | print "\nYOU HAVE ALREADY GUESSED THAT LETTER.\n\n"; 55 | } 56 | } else { 57 | print "\nPLEASE ENTER A SINGLE LETTER FROM A TO Z.\n\n"; 58 | } 59 | &print_noose( $num_wrong, @disp_word ); 60 | print "\nLetters Chosen: "; 61 | @guess = sort( keys( %guess ) ); 62 | print "@guess\n"; 63 | } 64 | if( $num_wrong == 6 ) { 65 | print "\nYOU LOSE!\nThe word was \"$word\".\n"; 66 | } else { 67 | print "\nYOU WIN!\n"; 68 | } 69 | print "\nPlay Again (y/N)? "; 70 | $cont = 71 | } 72 | print "\nTHANKS FOR PLAYING!\n"; 73 | 74 | sub get_a_word { 75 | my $wordlist = "wordlist.txt"; 76 | my( $fh, $word ); 77 | my( $random ) = rand(); 78 | 79 | open($fh, '<', $wordlist) or die "Could not open <$wordlist>: $!\n"; 80 | my $lines = 0; 81 | $lines++ while (<$fh>); 82 | die "Empty word list: $wordlist\n" unless $lines; 83 | my $val = int($random * $lines) + 1; 84 | close($fh) or die "Could not close <$wordlist>: $!\n"; 85 | 86 | open($fh, '<', $wordlist) or die "Could not open <$wordlist>: $!\n"; 87 | $word = <$fh> for (1 .. $val); 88 | die "Could not find a word in $wordlist\n" unless defined $word; 89 | chomp $word; 90 | close($fh) or die "Could not close <$wordlist>: $!\n"; 91 | return( $word ); 92 | } 93 | 94 | sub print_noose { 95 | my( $num, @y ) = @_; 96 | my( $line_1 ) = " +--+\n"; 97 | my( $line_2 ) = " |\n"; 98 | my( $line_3 ) = " |"; 99 | my( $line_4 ) = " |\n"; 100 | my( $line_5 ) = " |\n"; 101 | my( $line_6 ) = " ----+\n"; 102 | $line_2 = " O |\n" if( $num > 0 ); 103 | $line_3 = " | |" if( $num > 1 ); 104 | $line_3 = " /| |" if( $num > 2 ); 105 | $line_3 = " /|\\ |" if( $num > 3 ); 106 | $line_4 = " / |\n" if( $num > 4 ); 107 | $line_4 = " / \\ |\n" if( $num > 5 ); 108 | print "\n$line_1$line_2$line_3 @y\n$line_4$line_5$line_6"; 109 | } 110 | 111 | =encoding utf8 112 | 113 | =head1 NAME 114 | 115 | hangman - perl version of the game hangman 116 | 117 | =head1 SYNOPSIS 118 | 119 | B 120 | 121 | =head1 DESCRIPTION 122 | 123 | In B, the computer picks a word from the on-line, supplied 124 | word list, and you must try and guess it. The computer keeps track of 125 | which letters you have chosen, displaying them on each pass, and how 126 | many wrong guesses you have made, graphically displayed via the 127 | hangman's gallows. 128 | 129 | =head1 FILES 130 | 131 | F - make a list of words you'd like to use and put it 132 | in the current directory. 133 | 134 | =head1 AUTHOR 135 | 136 | Michael E. Schechter 137 | mschechter@earthlink.net 138 | 139 | =head1 COPYRIGHT INFORMATION 140 | 141 | This application is distributed as part of the Perl Power Tools. Feel 142 | free to copy, modify, delete, or whatever you would like with this 143 | file, under the information contained in the GNU GPL. 144 | 145 | =cut 146 | -------------------------------------------------------------------------------- /bin/head: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: head 6 | Description: print the first lines of a file 7 | Author: Abigail, perlpowertools@abigail.be 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | use File::Basename qw(basename); 18 | use Getopt::Std qw(getopts); 19 | 20 | use constant EX_SUCCESS => 0; 21 | use constant EX_FAILURE => 1; 22 | 23 | my $Program = basename($0); 24 | my ($VERSION) = '1.3'; 25 | 26 | @ARGV = new_argv(); 27 | my %opt; 28 | unless (getopts('n:', \%opt)) { 29 | warn "usage: $Program [-n count] [file ...]\n"; 30 | exit EX_FAILURE; 31 | } 32 | my $count; 33 | if (defined $opt{'n'}) { 34 | $count = $opt{'n'}; 35 | if ($count =~ m/[^0-9]/) { 36 | warn "$Program: invalid number '$count'\n"; 37 | exit EX_FAILURE; 38 | } 39 | if ($count == 0) { 40 | warn "$Program: count is too small\n"; 41 | exit EX_FAILURE; 42 | } 43 | } else { 44 | $count = 10; 45 | } 46 | 47 | my $rc = EX_SUCCESS; 48 | my $sep = 0; 49 | 50 | foreach my $file (@ARGV) { 51 | if (-d $file) { 52 | warn "$Program: '$file' is a directory\n"; 53 | $rc = EX_FAILURE; 54 | next; 55 | } 56 | my $fh; 57 | unless (open $fh, '<', $file) { 58 | warn "$Program: failed to open '$file': $!\n"; 59 | $rc = EX_FAILURE; 60 | next; 61 | } 62 | if (scalar(@ARGV) > 1) { 63 | if ($sep == 0) { 64 | $sep = 1; 65 | } else { 66 | print "\n"; 67 | } 68 | print "==> $file <==\n"; 69 | } 70 | head_fh($fh); 71 | unless (close $fh) { 72 | warn "$Program: failed to close '$file': $!\n"; 73 | $rc = EX_FAILURE; 74 | } 75 | } 76 | head_fh(*STDIN) unless @ARGV; 77 | exit $rc; 78 | 79 | sub head_fh { 80 | my $fh = shift; 81 | 82 | foreach (1 .. $count) { 83 | my $line = <$fh>; 84 | last unless (defined $line); 85 | print $line; 86 | } 87 | } 88 | 89 | sub new_argv { 90 | my @new; 91 | my $end = 0; 92 | 93 | foreach my $arg (@ARGV) { 94 | if ($arg eq '--' || $arg !~ m/\A\-/) { 95 | push @new, $arg; 96 | $end = 1; 97 | next; 98 | } 99 | 100 | if (!$end && $arg =~ m/\A\-([0-9]+)\Z/) { # historic 101 | push @new, "-n$1"; 102 | } else { 103 | push @new, $arg; 104 | } 105 | } 106 | return @new; 107 | } 108 | 109 | __END__ 110 | 111 | =pod 112 | 113 | =head1 NAME 114 | 115 | head - print the first lines of a file 116 | 117 | =head1 SYNOPSIS 118 | 119 | head [-n count] [files ...] 120 | 121 | =head1 DESCRIPTION 122 | 123 | I prints the first I lines from each file. If the I<-n> is 124 | not given, the first 10 lines will be printed. If no files are given, 125 | the first lines of standard input will be printed. 126 | 127 | =head2 OPTIONS 128 | 129 | I accepts the following options: 130 | 131 | =over 4 132 | 133 | =item -n count 134 | 135 | Print I lines instead of the default 10. 136 | 137 | =back 138 | 139 | =head1 ENVIRONMENT 140 | 141 | The working of I is not influenced by any environment variables. 142 | 143 | =head1 BUGS 144 | 145 | I has no known bugs. 146 | 147 | =head1 STANDARDS 148 | 149 | This I implementation is compliant with the B 150 | specification, also known as B. 151 | 152 | This I implementation is compatible with the B implementation. 153 | 154 | =head1 AUTHOR 155 | 156 | The Perl implementation of I was written by Abigail, I. 157 | 158 | =head1 COPYRIGHT and LICENSE 159 | 160 | This program is copyright by Abigail 1999. 161 | 162 | This program is free and open software. You may use, copy, modify, distribute 163 | and sell this program (and any modified variants) in any way you wish, 164 | provided you do not restrict others to do the same. 165 | 166 | =cut 167 | 168 | -------------------------------------------------------------------------------- /bin/kill: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: kill 6 | Description: send signals to a process 7 | Author: Theo Van Dinter, felicity@kluge.net 8 | License: 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # 16 | # An implementation of the 'kill' utility in Perl. Written for the Perl 17 | # Power Tools (PPT) project by Theo Van Dinter (felicity@kluge.net). 18 | 19 | use strict; 20 | use Config; 21 | 22 | usage() unless @ARGV; 23 | my @signals = getsigs(); 24 | my %hsignals = map { $_ => 1 } @signals; 25 | my $signal = 'TERM'; 26 | 27 | if ($ARGV[0] eq '-l') { # list signals 28 | siglist(); 29 | exit 0; 30 | } 31 | elsif ( $ARGV[0] =~ m/\A\-([0-9]+)\Z/ ) { # -signalnumber 32 | $signal = $1; 33 | shift @ARGV; 34 | if ($signal > $#signals) { 35 | print "$0: $signal: Unknown signal; valid signals...\n"; 36 | siglist(); 37 | exit 1; 38 | } 39 | } 40 | elsif ( $ARGV[0] =~ /\A\-(.+)\Z/ ) { # -NAME or -s NAME 41 | $signal = $1; 42 | shift @ARGV; 43 | $signal = shift @ARGV if ( lc $signal eq "s" ); # -s has signalname param. 44 | $signal = uc $signal; 45 | $signal =~ s/^SIG//; # remove the "SIG" from SIGNAME 46 | unless ($hsignals{$signal}) { 47 | print "$0: $signal: Unknown signal; valid signals...\n"; 48 | siglist(); 49 | exit 1; 50 | } 51 | } 52 | 53 | die "$0: No PIDs specified.\n" unless ( @ARGV ); 54 | 55 | my($ret) = 0; 56 | foreach ( @ARGV ) { # do the kills... 57 | unless (m/\A\-?[0-9]+\Z/) { 58 | warn "$0: failed to parse argument '$_'\n"; 59 | exit 1; 60 | } 61 | unless (kill $signal, $_) { 62 | warn "$0: $_: $!\n"; 63 | $ret = 1; 64 | } 65 | } 66 | 67 | exit $ret; 68 | 69 | sub usage { 70 | print "usage: $0 [-s signalname] PID... 71 | $0 [-signalname] PID... 72 | $0 [-signalnumber] PID... 73 | $0 PID... 74 | $0 [-l] 75 | "; 76 | exit 1; 77 | } 78 | 79 | sub siglist { 80 | foreach my $i (1 .. $#signals) { 81 | printf "%2d:%-6s%s",$i,$signals[$i], 82 | ( ($i % 8 == 0) || ($i == $#signals) )?"\n":" "; 83 | } 84 | } 85 | 86 | sub getsigs { 87 | die 'no signal names detected' unless defined $Config{'sig_name'}; 88 | my @names = split/\s+/, $Config{'sig_name'}; 89 | die 'empty signal list' unless @names; 90 | return @names; 91 | } 92 | 93 | =head1 NAME 94 | 95 | kill - send signals to a process 96 | 97 | =head1 SYNOPSIS 98 | 99 | B 100 | [ B<-s> I C ] 101 | [ B<-signalname> C ] 102 | [ B<-signalnumber> C ] 103 | [ C ] 104 | [ B<-l> ] 105 | 106 | =head1 DESCRIPTION 107 | 108 | B sends a signal to all PIDS specified on the command line. This is 109 | typically done to cause a process to terminate and/or to reload configuration 110 | files, etc. Signal handlers are specified per program, so the effects of a 111 | received signal may vary. 112 | 113 | =head1 OPTIONS AND ARGUMENTS 114 | 115 | =over 4 116 | 117 | =item I<-s> This parameter takes a single argument of a signal name (see -l) 118 | to be sent to the specified PIDs. 119 | 120 | =item I<-signalname> A short form of the C<-s signalname> parameter. 121 | 122 | =item I<-signalnumber> This parameter specifies that the given signal number 123 | should be sent to the specified PID listing. 124 | 125 | =item I<-l> Display a listing of all available signals on the current system. 126 | 127 | =back 128 | 129 | =head1 NOTES 130 | 131 | If no signal is specified on the command line, SIGTERM is sent to the 132 | specified PIDs. 133 | 134 | kill returns 0 on success or >0 if an error occurred. 135 | 136 | kill is built-in to csh(1); See csh(1) for details. 137 | 138 | Only the super-user may send signals to other users' processes. 139 | 140 | This version of kill does not support I<-l [signal]> since there didn't seem 141 | to be any use to the parameter (it didn't work on any platform I tried 142 | either.) 143 | 144 | Signal names may have the I prefix. i.e.: C and C are equivalent. 146 | 147 | The signal list C displays in an "extended" form which lists both 148 | the signal name and the signal number for easy reference. 149 | 150 | =head1 HISTORY 151 | 152 | Perl version rewritten for the Perl Power Tools project from the 153 | description of the kill program in OpenBSD. 154 | 155 | =head1 AUTHOR 156 | 157 | Theo Van Dinter (felicity@kluge.net) 158 | 159 | =head1 SEE ALSO 160 | 161 | csh(1), ps(1), kill(2) 162 | 163 | -------------------------------------------------------------------------------- /bin/ln: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: ln 6 | Description: create links 7 | Author: Abigail, perlpowertools@abigail.be 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | use strict; 15 | 16 | use File::Basename qw(basename); 17 | use Getopt::Std qw(getopts); 18 | 19 | use constant EX_SUCCESS => 0; 20 | use constant EX_FAILURE => 1; 21 | 22 | our $VERSION = '1.3'; 23 | my $Program = basename($0); 24 | 25 | getopts('sf', \my %options) or usage(); 26 | usage() unless @ARGV; 27 | 28 | my $target = pop @ARGV; 29 | if (scalar(@ARGV) == 0 && -d $target) { 30 | warn "$Program: '$target': cannot overwrite directory\n"; 31 | exit EX_FAILURE; 32 | } 33 | 34 | # Deal with the force option in that case of a "file" target. 35 | unless (-d $target) { 36 | if (exists $options{'f'} && -e $target) { 37 | unless (unlink $target) { 38 | warn "$Program: cannot unlink '$target': $!\n"; 39 | exit EX_FAILURE; 40 | } 41 | } 42 | } 43 | 44 | my $rc = EX_SUCCESS; 45 | foreach my $file (@ARGV) { 46 | my $this_target; 47 | if (-d $target) { 48 | require File::Spec; 49 | my $this_file = basename($file); 50 | $this_target = File::Spec->catfile($target, $this_file); 51 | # Deal with the force option. 52 | if (exists $options{'f'} && -e $this_target) { 53 | unless (unlink $this_target) { 54 | warn "$Program: cannot unlink '$this_target': $!\n"; 55 | $rc = EX_FAILURE; 56 | next; 57 | } 58 | } 59 | } 60 | else { 61 | $this_target = $target; 62 | } 63 | 64 | unless (dolink($file, $this_target)) { 65 | warn "$Program: failed to link '$file' to '$this_target': $!\n"; 66 | $rc = EX_FAILURE; 67 | } 68 | } 69 | unless (@ARGV) { 70 | my $newfile = basename($target); 71 | unless (dolink($target, $newfile)) { 72 | warn "$Program: failed to link '$target' to '$newfile': $!\n"; 73 | $rc = EX_FAILURE; 74 | } 75 | } 76 | exit $rc; 77 | 78 | sub VERSION_MESSAGE { 79 | print "$Program version $VERSION\n"; 80 | exit EX_SUCCESS; 81 | } 82 | 83 | sub usage { 84 | warn "usage: $Program [-sf] source_file [target_file | [source_files ...] target_directory]\n"; 85 | exit EX_FAILURE; 86 | } 87 | 88 | sub dolink { 89 | my ($file, $target) = @_; 90 | return symlink($file, $target) if $options{'s'}; 91 | return link($file, $target); 92 | } 93 | 94 | __END__ 95 | 96 | =pod 97 | 98 | =head1 NAME 99 | 100 | ln - create links 101 | 102 | =head1 SYNOPSIS 103 | 104 | B [B<-sf>] I [I | [I ... I]] 105 | 106 | =head1 DESCRIPTION 107 | 108 | B creates I or I between files. If more than one 109 | argument is given, and the last argument is a directory, links will be 110 | created in this directory; their names will consist of the last components 111 | of the I. If only one argument is given, the link will be 112 | created in the current directory, and its name will consist of the last 113 | component of the I. 114 | 115 | =head2 OPTIONS 116 | 117 | B accepts the following options: 118 | 119 | =over 4 120 | 121 | =item B<-s> 122 | 123 | Create symbolic links (hard links are created by default) 124 | 125 | =item B<-f> 126 | 127 | If the I is not a directory, try to remove any existing 128 | Is before creating the links. Failure of removing the 129 | target results in a warning and no further attempt to make the 130 | link will be made. 131 | 132 | =back 133 | 134 | =head1 ENVIRONMENT 135 | 136 | The working of B is not influenced by any environment variables. 137 | 138 | =head1 PORTABILITY 139 | 140 | B will not do much on platforms that do not know the concept of 141 | links. B will not do much on platforms that do know symbolic links. 142 | 143 | =head1 BUGS 144 | 145 | There are no known bugs in this implementation of B. 146 | 147 | =head1 AUTHOR 148 | 149 | The Perl implementation of B was written by Abigail, I. 150 | 151 | =head1 COPYRIGHT and LICENSE 152 | 153 | This program is copyright by Abigail 1999. 154 | 155 | This program is free and open software. You may use, copy, modify, distribute, 156 | and sell this program (and any modified variants) in any way you wish, 157 | provided you do not restrict others from doing the same. 158 | 159 | =cut 160 | 161 | -------------------------------------------------------------------------------- /bin/look: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: look 6 | Description: find lines in a sorted list 7 | Author: Tom Christiansen, tchrist@perl.com 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # look - display lines beginning with a given search 16 | 17 | use strict; 18 | use locale; 19 | 20 | use File::Basename qw(basename); 21 | use Getopt::Std qw(getopts); 22 | use Search::Dict; 23 | 24 | use constant EX_FOUND => 0; 25 | use constant EX_NOTFOUND => 1; 26 | use constant EX_FAILURE => 2; 27 | 28 | my $Program = basename($0); 29 | 30 | sub usage { 31 | warn "usage: $Program [-df] string [file]\n"; 32 | exit EX_FAILURE; 33 | } 34 | 35 | my ( 36 | @dicts, # file list 37 | $filearg, # optional file argument 38 | $search, # the string to look for 39 | %opt, # option hash 40 | ); 41 | 42 | getopts('df', \%opt) or usage(); 43 | 44 | @dicts = qw( 45 | /usr/dict/words 46 | /usr/share/dict/words 47 | ); 48 | 49 | $search = shift; 50 | if (!defined($search)) { 51 | warn "$Program: missing search pattern\n"; 52 | usage(); 53 | } 54 | $filearg = shift; 55 | if (@ARGV) { 56 | warn "$Program: extra argument: '$ARGV[0]'\n"; 57 | usage(); 58 | } 59 | 60 | if (defined $filearg) { 61 | @dicts = ($filearg); 62 | } else { 63 | @opt{ qw/d f/ } = (1, 1); 64 | } 65 | 66 | $search = squish($search); 67 | my $dict = open_dict(); 68 | my $rc = lookfile($dict); 69 | unless (close $dict) { 70 | warn "$Program: can't close dictionary: $!\n"; 71 | exit EX_FAILURE; 72 | } 73 | exit $rc; 74 | 75 | sub open_dict { 76 | my $fh; 77 | for my $file (@dicts) { 78 | if (-d $file) { 79 | warn "$Program: '$file' is a directory\n"; 80 | next; 81 | } 82 | unless (open $fh, '<', $file) { 83 | warn "$Program: can't open '$file': $!\n" unless is_default_dict(); 84 | next; 85 | } 86 | return $fh; 87 | } 88 | warn "$Program: No dictionaries available (@dicts)\n" if is_default_dict(); 89 | exit EX_FAILURE; 90 | } 91 | 92 | sub lookfile { 93 | my $fh = shift; 94 | if (look($fh, $search, $opt{'d'}, $opt{'f'}) == -1) { 95 | return EX_NOTFOUND; 96 | } 97 | my $match = EX_NOTFOUND; 98 | while (<$fh>) { 99 | last if (index(squish($_), $search) != 0); 100 | $match = EX_FOUND; 101 | print; 102 | } 103 | return $match; 104 | } 105 | 106 | sub squish { 107 | my $str = shift; 108 | $str = lc($str) if $opt{'f'}; 109 | $str =~ s/[^\w\s]//g if $opt{'d'}; 110 | return $str; 111 | } 112 | 113 | sub is_default_dict { 114 | return !defined($filearg); 115 | } 116 | 117 | __END__ 118 | 119 | =head1 NAME 120 | 121 | look - find lines in a sorted list 122 | 123 | =head1 SYNOPSIS 124 | 125 | look [-df] string [file] 126 | 127 | =head1 DESCRIPTION 128 | 129 | Look uses a binary search against a sorted file to print out 130 | all lines that begin with the given string. It does make 131 | use of Perl's C pragma. 132 | 133 | The B<-d> and B<-f> options affect comparisons as in sort(1): 134 | 135 | =over 136 | 137 | =item -d 138 | 139 | `Dictionary' order: only non-alphanumerics and underscores 140 | participate in comparisons. 141 | 142 | =item -f 143 | 144 | Fold. Upper case letters compare equal to lower case. 145 | 146 | =back 147 | 148 | If no file is specified, F (or F 149 | if the former is missing) is assumed with a collating sequence B<-df>. 150 | 151 | =head1 FILES 152 | 153 | /usr/dict/words 154 | 155 | /usr/share/dict/words 156 | 157 | =head1 SEE ALSO 158 | 159 | sort(1), grep(1), L 160 | 161 | =head1 BUGS 162 | 163 | I has no known bugs. 164 | 165 | =head1 AUTHOR 166 | 167 | The Perl implementation of I was written by Tom Christiansen, 168 | I. 169 | 170 | =head1 COPYRIGHT and LICENSE 171 | 172 | This program is copyright (c) Tom Christiansen 1999. 173 | 174 | This program is free and open software. You may use, modify, distribute, 175 | and sell this program (and any modified variants) in any way you wish, 176 | provided you do not restrict others from doing the same. 177 | -------------------------------------------------------------------------------- /bin/mimedecode: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: mimedecode 6 | Description: extract MIME attachments in uudecode-like manner 7 | Author: Nick Ing-Simmons, nick@ni-s.u-net.com 8 | License: 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | use v5.12.0; 15 | use Getopt::Std; 16 | 17 | SANITY: { 18 | my $external_module = 'MIME::Parser'; 19 | my $rc = eval "require $external_module; $external_module->import; 1"; 20 | die "This program needs the $external_module module.\n" unless $rc; 21 | } 22 | 23 | {package PerlPowerTools::MIME::Parser; 24 | push @INC, 'MIME::Parser'; # this is old school so -c doesn't complain 25 | 26 | sub new_body_for 27 | { 28 | my ($parser,$head) = @_; 29 | my $outname = $head->recommended_filename; 30 | if (defined $outname) 31 | { 32 | return MIME::Body::File->new($parser->output_path($head)); 33 | } 34 | else 35 | { 36 | return MIME::Body::Scalar->new; 37 | } 38 | } 39 | 40 | } 41 | 42 | my %opt = ( 'd' => '.' ); 43 | 44 | getopts('d:',\%opt); 45 | 46 | my $parser = PerlPowerTools::MIME::Parser->new; 47 | $parser->output_dir($opt{'d'}); 48 | 49 | if (@ARGV) 50 | { 51 | foreach my $file (@ARGV) 52 | { 53 | my $entity = $parser->parse_in($file); 54 | } 55 | } 56 | else 57 | { 58 | my $entity = $parser->read(\*STDIN); 59 | } 60 | 61 | __END__ 62 | 63 | =head1 NAME 64 | 65 | mimedecode - extract MIME attachments in uudecode-like manner 66 | 67 | =head1 SYNOPSIS 68 | 69 | mimedecode [-d directory] < file 70 | 71 | mimedecode [-d directory] file... 72 | 73 | =head1 DESCRIPTION 74 | 75 | C processes mail files using B module. 76 | It handles "multipart" messages and saves "attached" files 77 | (i.e. parts with suggested file names) to their suggested names 78 | in the directory specified after C<-d>, or the current directory if 79 | C<-d> is not given. 80 | 81 | =head1 BUGS 82 | 83 | It needs the module installed. 84 | 85 | Should probably consider more of headers in deciding if it really 86 | is a useful attachment. 87 | 88 | =head1 AUTHOR 89 | 90 | Slapped together by Nick Ing-Simmons 91 | 92 | =cut 93 | 94 | 95 | -------------------------------------------------------------------------------- /bin/mkfifo: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: mkfifo 6 | Description: make named pipes 7 | Author: Jeffrey S. Haemer 8 | Author: Louis Krupp 9 | License: perl 10 | 11 | =end metadata 12 | 13 | =cut 14 | 15 | 16 | use strict; 17 | 18 | use File::Basename qw(basename); 19 | use POSIX "mkfifo"; 20 | use Getopt::Std; 21 | 22 | use constant EX_SUCCESS => 0; 23 | use constant EX_FAILURE => 1; 24 | 25 | use vars qw($opt_m); 26 | 27 | my $Program = basename($0); 28 | 29 | getopts('m:') and @ARGV or usage(); 30 | 31 | sub default_mode { 32 | return 0666 & ~(umask); 33 | } 34 | 35 | sub usage { 36 | warn "$Program: [-m mode] filename...\n"; 37 | exit EX_FAILURE; 38 | } 39 | 40 | sub sym_perms { 41 | my $sym = shift; 42 | my $mode = default_mode(); 43 | 44 | my %who = (u => 0700, g => 0070, o => 0007); 45 | my %what = (r => 0444, w => 0222, x => 0111); 46 | 47 | my ($who, $how, $what) = split /([+-=])/, $sym; 48 | $who =~ s/a/ugo/g; 49 | 50 | my @who = split //, $who; 51 | my $who_mask = 0; 52 | foreach (@who) { 53 | $who_mask |= $who{$_}; 54 | } 55 | 56 | my @what = split //, $what; 57 | my $what_mask = 0; 58 | foreach (@what) { 59 | $what_mask |= $what{$_}; 60 | } 61 | 62 | if ($how eq '+') { 63 | $mode |= ($who_mask & $what_mask); 64 | } elsif ($how eq '-') { 65 | $mode &= ~($who_mask & $what_mask); 66 | } elsif ($how eq '=') { 67 | $mode = ($mode & ~$who_mask) | ($who_mask & $what_mask); 68 | } 69 | } 70 | 71 | sub get_mode { 72 | my $mode = shift; 73 | my $real_mode; 74 | 75 | if ($mode =~ /^0?[0-7]{1,3}$/) { 76 | $real_mode = oct $mode; 77 | } else { 78 | $real_mode = sym_perms($mode); 79 | } 80 | if ($real_mode < 0) { 81 | warn "$Program: bad file mode: '$mode'\n"; 82 | exit EX_FAILURE; 83 | } 84 | return $real_mode; 85 | } 86 | 87 | my $mode = defined $opt_m ? get_mode($opt_m) : default_mode(); 88 | 89 | my $rc = EX_SUCCESS; 90 | foreach my $fifo (@ARGV) { 91 | if (-e $fifo) { 92 | warn "$Program: '$fifo': file already exists\n"; 93 | $rc = EX_FAILURE; 94 | next; 95 | } 96 | unless (mkfifo($fifo, $mode)) { 97 | warn "$Program: '$fifo': $!\n"; 98 | $rc = EX_FAILURE; 99 | next; 100 | } 101 | } 102 | exit $rc; 103 | 104 | =head1 NAME 105 | 106 | mkfifo - make named pipes 107 | 108 | =head1 SYNOPSIS 109 | 110 | mkfifo "-m mode" filename ... 111 | 112 | =head1 DESCRIPTION 113 | 114 | =over 2 115 | 116 | Create one or more named pipes, in the order specified, 117 | with the mode given. 118 | 119 | If no mode is given, create them with mode 0666, modified by the umask. 120 | 121 | =back 122 | 123 | =head1 OPTIONS AND ARGUMENTS 124 | 125 | =over 8 126 | 127 | =item I<-m> 128 | 129 | The mode the fifo should be created with. 130 | 131 | Numbers must be three octal digits (as for B. 132 | 133 | Symbolic modes, specified the way you can for B 134 | (such as C) are also acceptable. 135 | 136 | =item I 137 | 138 | One or more fifo names to create 139 | 140 | =back 141 | 142 | =head1 AUTHOR 143 | 144 | Jeffrey S. Haemer and Louis Krupp 145 | 146 | =head1 SEE ALSO 147 | 148 | chmod(1) umask(1) mkfifo(2) 149 | 150 | =cut 151 | -------------------------------------------------------------------------------- /bin/moo: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: moo 6 | Description: play a game of MOO 7 | Author: Abigail, perlpowertools@abigail.be 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | use strict; 15 | 16 | use List::Util qw(shuffle); 17 | 18 | my ($VERSION) = '1.4'; 19 | 20 | sub usage { 21 | die "usage: moo [size]\n"; 22 | } 23 | 24 | sub get_secret { 25 | my $size = shift; 26 | 27 | my $i = $size - 1; 28 | my %digits = map { $_ => 1 } (0 .. 9); 29 | my @s1 = keys %digits; 30 | my @s2 = shuffle(@s1); 31 | return @s2[0 .. $i]; 32 | } 33 | 34 | sub has_dupe { 35 | my $guess = shift; 36 | my %chars; 37 | foreach my $c (split //, $guess) { 38 | return 1 if exists $chars{$c}; 39 | $chars{$c} = 1; 40 | } 41 | return 0; 42 | } 43 | 44 | my $size = shift; 45 | $size = 4 unless defined $size; 46 | usage() if $size !~ m/\A[0-9]+\Z/ or !$size; 47 | die "secret size must be within range: 1-10\n" if $size > 10; 48 | usage() if @ARGV; 49 | 50 | print "MOO\n"; 51 | { 52 | my @secret = get_secret($size); 53 | my @secret_by_value = (0) x 10; 54 | foreach my $i (@secret) { 55 | $secret_by_value[$i] = 1; 56 | } 57 | 58 | my $attempts = 0; 59 | 60 | print "New game\n"; 61 | 62 | { 63 | print "Your guess? "; 64 | chomp (my $guess = <>); 65 | exit if (!defined($guess) || $guess =~ m/\Aq/i); 66 | 67 | if ($guess =~ /\D/ || length $guess != $size || has_dupe($guess)) { 68 | print "Bad guess\n"; 69 | redo 70 | } 71 | 72 | ++ $attempts; 73 | 74 | my @guess = split // => $guess; 75 | 76 | # Count the number of bulls and cows. We need a copy of 77 | # @secret_by_value for that. 78 | my $bulls = 0; 79 | my $cows = 0; 80 | my @cows = @secret_by_value; 81 | 82 | # We have to count the bulls before counting the cows. 83 | for (my $i = 0; $i < @guess; $i ++) { 84 | if ($secret [$i] == $guess [$i]) { 85 | $bulls ++; 86 | $cows [$guess [$i]] -- if $cows [$guess [$i]]; 87 | } 88 | } 89 | 90 | for (my $i = 0; $i < @guess; $i ++) { 91 | next if $secret [$i] == $guess [$i]; # Counted the bulls already. 92 | if ($cows [$guess [$i]]) { 93 | $cows [$guess [$i]] --; 94 | $cows ++; 95 | } 96 | } 97 | 98 | print "Bulls = $bulls\tCows = $cows\n"; 99 | 100 | if ($bulls == $size) { 101 | # Won the game! 102 | print "Attempts = $attempts\n"; 103 | last; 104 | } 105 | 106 | redo; 107 | } 108 | 109 | redo; 110 | } 111 | 112 | __END__ 113 | 114 | =pod 115 | 116 | =head1 NAME 117 | 118 | moo - play a game of MOO 119 | 120 | =head1 SYNOPSIS 121 | 122 | moo [size] 123 | 124 | =head1 DESCRIPTION 125 | 126 | I is a game where the user guesses a random number chosen by 127 | the computer. By default, the computer takes a number of four distinct digits 128 | (including 0's), but that can be changed by giving I the number of 129 | digits to take. After each guess, the number of Bs and Bs 130 | is displayed. A B is a correctly guessed digit, in the right 131 | place, while a B is a correct digit, not in the right place. Once 132 | a game has finished because all the digits have been guessed correctly, 133 | a new game will be started. Exiting the program can be done by typing 134 | 'q' or 'Q' on a guess, or hitting the interrupt key (usually control-C). 135 | 136 | =head2 OPTIONS 137 | 138 | The only option I takes is optional, and is the number of digits to 139 | use for the number to guess. 140 | 141 | =head1 ENVIRONMENT 142 | 143 | The working of I is not influenced by any environment variables. 144 | 145 | =head1 BUGS 146 | 147 | I does not have any known bugs. 148 | 149 | =head1 AUTHOR 150 | 151 | The Perl implementation of I was written by Abigail, I. 152 | 153 | =head1 COPYRIGHT and LICENSE 154 | 155 | This program is copyright by Abigail 1999. 156 | 157 | This program is free and open software. You may use, copy, modify, distribute 158 | and sell this program (and any modified variants) in any way you wish, 159 | provided you do not restrict others to do the same. 160 | 161 | =cut 162 | 163 | -------------------------------------------------------------------------------- /bin/paste: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: paste 6 | Description: merge corresponding or subsequent lines of files 7 | Author: Randy Yarger, randy.yarger@nextel.com 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | use File::Basename qw(basename); 18 | use Getopt::Std qw(getopts); 19 | 20 | use constant EX_SUCCESS => 0; 21 | use constant EX_FAILURE => 1; 22 | 23 | my $Program = basename($0); 24 | my ($VERSION) = '1.4'; 25 | my (@fh, @sep, %opt); 26 | 27 | getopts('d:s', \%opt) or usage(); 28 | @ARGV or usage(); 29 | 30 | if (defined $opt{'d'}) { 31 | @sep = split //, eval { "$opt{d}" }; 32 | } else { 33 | @sep = ("\t"); 34 | } 35 | 36 | foreach my $f (@ARGV) { 37 | if ($f eq '-') { 38 | push @fh, *STDIN; 39 | } else { 40 | if (-d $f) { 41 | warn "$Program: '$f': is a directory\n"; 42 | exit EX_FAILURE; 43 | } 44 | my $fil; 45 | unless (open $fil, '<', $f) { 46 | warn "$Program: '$f': $!\n"; 47 | exit EX_FAILURE; 48 | } 49 | push @fh, $fil; 50 | } 51 | } 52 | 53 | if ($opt{'s'}) { 54 | for my $i (0..$#fh) { 55 | my $fh = $fh[$i]; 56 | my $current_sep = 0; 57 | my $tline; 58 | while(<$fh>) { 59 | chomp; 60 | $tline .= $_ . $sep[$current_sep]; 61 | $current_sep = ($current_sep + 1) % scalar(@sep); 62 | } 63 | chop $tline; 64 | print "$tline\n"; 65 | close $fh; 66 | } 67 | exit EX_SUCCESS; 68 | } 69 | 70 | while (files_open()) { 71 | my $current_sep = 0; 72 | my $tline; 73 | for my $i (0..$#fh) { 74 | if (not eof $fh[$i]) { 75 | my $fh = $fh[$i]; 76 | my $line = <$fh>; 77 | chomp($line); 78 | $tline .= $line; 79 | } 80 | if ($i != $#fh) { 81 | $tline .= $sep[$current_sep]; 82 | $current_sep = ($current_sep + 1) % scalar(@sep); 83 | } 84 | } 85 | print "$tline\n"; 86 | } 87 | exit EX_SUCCESS; 88 | 89 | sub files_open { 90 | for my $f (@fh) { 91 | return 1 unless eof $f; 92 | } 93 | return 0; 94 | } 95 | 96 | sub usage { 97 | print "usage: $Program [-s] [-d list] file ...\n"; 98 | exit EX_FAILURE; 99 | } 100 | 101 | sub VERSION_MESSAGE { 102 | print "$Program version $VERSION\n"; 103 | exit EX_SUCCESS; 104 | } 105 | 106 | __END__ 107 | 108 | =pod 109 | 110 | =head1 NAME 111 | 112 | paste - merge corresponding or subsequent lines of files 113 | 114 | =head1 SYNOPSIS 115 | 116 | paste [-s] [-d list] file ... 117 | 118 | =head1 DESCRIPTION 119 | 120 | Paste combines the corresponding lines of multiple files. Each line of each 121 | file is printed separated by a tab character (or by the characters listed in the -d 122 | option). 123 | 124 | The argument '-' will result in standard input being read. 125 | If '-' is repeated, standard input will be read one line at a time for each instance of '-'. 126 | 127 | =head2 OPTIONS 128 | 129 | I accepts the following options: 130 | 131 | =over 4 132 | 133 | =item -d list 134 | 135 | Define the column delimiters. Each character in this list will be used 136 | one at a time, as a delimiter for the columns. If there are fewer characters 137 | than columns, the characters will be repeated. Standard Perl special characters 138 | ("\n", "\t", etc.) are recognized. 139 | 140 | =item -s 141 | 142 | Displays the output one file per row, rather than interleaving the 143 | lines of the files. 144 | 145 | =back 146 | 147 | =head1 ENVIRONMENT 148 | 149 | The working of I is not influenced by any environment variables. 150 | 151 | =head1 BUGS 152 | 153 | I has no known bugs, unless you count the use of eval EXPR. 154 | 155 | =head1 AUTHOR 156 | 157 | The Perl implementation of I 158 | was written by Randy Yarger, I. 159 | 160 | =head1 COPYRIGHT and LICENSE 161 | 162 | This program is copyright by Randy Yarger 1999. 163 | 164 | This program is free and open software. You may use, modify, distribute 165 | and sell this program (and any modified variants) in any way you wish, 166 | provided you do not restrict others to do the same. 167 | 168 | =cut 169 | 170 | Randy Jay Yarger | Nextel Communications 171 | randy.yarger@nextel.com | http://hs1.hst.msu.edu/~randy/ 172 | 173 | 174 | -------------------------------------------------------------------------------- /bin/perldoc: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # perldoc - perldoc for PerlPowerTools 4 | 5 | =begin metadata 6 | 7 | Name: perldoc 8 | Description: perldoc for perlpowertools 9 | Author: jul, kaldor@cpan.org 10 | License: artistic2 11 | 12 | =end metadata 13 | 14 | =cut 15 | 16 | use strict; 17 | use warnings; 18 | use utf8; 19 | use File::Basename; 20 | use Cwd 'abs_path'; 21 | 22 | # let perldoc also search in perlpowertools bin 23 | unshift @INC, dirname(abs_path(__FILE__)); 24 | 25 | # copy-paste from the real perldoc 26 | require 5; 27 | BEGIN { $^W = 1 if $ENV{'PERLDOCDEBUG'} } 28 | use Pod::Perldoc; 29 | exit( Pod::Perldoc->run() ); 30 | -------------------------------------------------------------------------------- /bin/perlpowertools: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # perlpowertools - helper script for PerlPowerTools 4 | 5 | =begin metadata 6 | 7 | Name: perlpowertools 8 | Description: a program launcher for Perl Power Tools 9 | Author: kal247, https://github.com/kal247 10 | License: artistic2 11 | 12 | =end metadata 13 | 14 | =cut 15 | 16 | use strict; 17 | use warnings; 18 | use utf8; 19 | use Getopt::Std; 20 | use File::Basename; 21 | use Cwd 'abs_path'; 22 | 23 | our $VERSION = qw( 1.025 ); 24 | my $program = 'perlpowertools'; 25 | my @tools = qw( addbib apply ar arch arithmetic asa awk banner base64 26 | basename bc bcd cal cat chgrp ching chmod chown clear cmp col colrm comm cp 27 | cut date dc deroff diff dirname du echo ed env expand expr factor false file 28 | find fish fmt fold fortune from glob grep hangman head hexdump id install 29 | join kill ln lock look ls mail maze mimedecode mkdir mkfifo moo morse nl od 30 | par paste patch perldoc pig ping pom ppt pr primes printenv printf pwd rain 31 | random rev rm rmdir robots rot13 seq shar sleep sort spell split strings sum 32 | tac tail tar tee test time touch tr true tsort tty uname unexpand uniq units 33 | unlink unpar unshar uudecode uuencode wc what which whoami whois words wump 34 | xargs yes ); 35 | my $usage = < 0; 22 | use constant EX_FAILURE => 1; 23 | 24 | $|++; 25 | 26 | our $VERSION = '1.0'; 27 | my $Program = basename($0); 28 | 29 | sub VERSION_MESSAGE { 30 | warn "$Program version $VERSION\n"; 31 | exit EX_SUCCESS; 32 | } 33 | 34 | sub help { 35 | warn "usage: $Program\n"; 36 | exit EX_FAILURE; 37 | } 38 | 39 | # Dr. Bronner's top secret pig-latin algorithm! 40 | # ALL-ONE! ALL-ONE! ALL-ONE! 41 | sub igpay { 42 | local $_ = shift; 43 | my $ordway; 44 | my $initcaps = /^[A-Z]/; 45 | my $allcaps = /^[A-Z]+$/; 46 | if (/^[aeiou]/i) { 47 | $ordway = $_ . ($allcaps ? 'WAY' : 'way'); 48 | } 49 | else { 50 | /([^aieou]+)(.*)/i; 51 | $ordway = ($2 || '') . lcfirst $1 . 'ay'; 52 | if ($allcaps) { 53 | $ordway = uc $ordway; 54 | } elsif ($initcaps) { 55 | $ordway = ucfirst $ordway; 56 | } 57 | } 58 | return $ordway; 59 | } 60 | 61 | getopts('') or help(); 62 | @ARGV = (); # stdin only 63 | 64 | while (<>) { 65 | s/([A-Z]+)/igpay($1)/gexi; 66 | print; 67 | } 68 | exit EX_SUCCESS; 69 | 70 | __END__ 71 | 72 | =head1 NAME 73 | 74 | pig - eformatray inputway asway Igpay Atinlay 75 | 76 | =head1 SYNOPSIS 77 | 78 | B 79 | 80 | =head1 DESCRIPTION 81 | 82 | Ethay igpay utilityway eadsray ethay andardstay inputway andway iteswray 83 | itway outway otay andardstay outputway inway Igpay Atinlay. 84 | 85 | Usefulway orfay eneratinggay onthlymay eportsray. 86 | 87 | =head1 BUGS 88 | 89 | I ashay onay ownknay ugsbay. 90 | 91 | =head1 AUTHOR 92 | 93 | Ethay Erlpay implementationway ofway I asway ittenwray byay 94 | Onathanjay Einbergfay, I. 95 | 96 | =head1 COPYRIGHT and LICENSE 97 | 98 | Isthay ogrampray isway opyrightcay (c) Onathanjay Einbergfay 1999. 99 | 100 | Isthay ogrampray isway eefray andway openway oftwaresay. Ouyay aymay 101 | useway, odifymay, istributeday, andway ellsay isthay ogrampray (andway 102 | anyway odifiedmay ariantsvay) inway anyway ayway ouyay ishway, 103 | ovidedpray ouyay oday otnay estrictray othersway omfray oingday ethay 104 | amesay. 105 | 106 | -------------------------------------------------------------------------------- /bin/ping: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: ping 6 | Description: probe for network hosts 7 | Author: Nick Ing-Simmons, nick@ni-s.u-net.com 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | use Getopt::Std; 17 | use Socket; 18 | use Net::Ping; 19 | 20 | sub usage { 21 | require Pod::Usage; 22 | Pod::Usage::pod2usage({ -exitval => 1, -verbose => 0 }); 23 | } 24 | 25 | my %opt; 26 | getopts('nI:', \%opt) or usage(); 27 | my $host = shift; 28 | my $timeout = shift; 29 | usage() unless defined $host; 30 | $timeout = 20 unless defined $timeout; 31 | usage() if @ARGV; 32 | 33 | my $a = gethostbyname($host); 34 | 35 | if ( $a ) { 36 | 37 | if ( $opt{'n'} ) { 38 | 39 | my $name = inet_ntoa($a); 40 | $host = $name if ($name); 41 | 42 | } else { 43 | 44 | my $name = gethostbyaddr($a,PF_INET); 45 | $host = $name if ($name); 46 | } 47 | 48 | my $handle = Net::Ping->new($> ? 'udp' : 'icmp', $timeout); 49 | 50 | if ( $handle->ping($host) ) { 51 | 52 | warn "$host is alive\n"; 53 | 54 | } else { 55 | 56 | die "No answer from $host"; 57 | } 58 | } else { 59 | 60 | die "Unknown host $host\n"; 61 | } 62 | 63 | __END__ 64 | 65 | =head1 NAME 66 | 67 | ping - probe for network hosts 68 | 69 | =head1 SYNOPSIS 70 | 71 | ping [-n] hostname [ timeout ] 72 | 73 | =head1 DESCRIPTION 74 | 75 | C looks up I and then attempts to contact it via the network. 76 | If the effective userid permits an ICMP (Internet Control Message Protocol) 77 | ECHO_REQUEST packet is sent, otherwise and attempt is made to connect to 78 | the echo port using UDP protocol. 79 | 80 | A I may be specified in seconds. The default is 20 seconds. 81 | 82 | If C<-n> option is specified then the address of I is reported 83 | as numbers. 84 | 85 | =head1 AUTHOR 86 | 87 | Nick Ing-Simmons 88 | 89 | =cut 90 | -------------------------------------------------------------------------------- /bin/ppt: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -0777 2 | 3 | =begin metadata 4 | 5 | Name: ppt 6 | Description: reformat input as paper tape 7 | Author: Mark-Jason Dominus, mjd@plover.com 8 | License: 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | use strict; 15 | 16 | # ppt - reformat input as paper tape 17 | # mjd@plover.com 18 | 19 | print "----------\n"; 20 | for (split //, <>) { 21 | $_ = unpack "B8", $_; 22 | s/.(....)(...)/$1.$2/; 23 | tr/01/ o/; 24 | print "|$_|\n"; 25 | } 26 | 27 | print "----------\n"; 28 | 29 | =encoding utf8 30 | 31 | =head1 NAME 32 | 33 | ppt - reformat input as paper tape 34 | -------------------------------------------------------------------------------- /bin/printenv: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: printenv 6 | Description: display the environment 7 | Author: Randy Yarger, randy.yarger@nextel.com 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | my ($VERSION) = '1.3'; 18 | 19 | my $rc = 0; 20 | my $arg = shift; 21 | if (defined $arg) { 22 | if (exists $ENV{$arg}) { 23 | print $ENV{$arg}, "\n"; 24 | } else { 25 | $rc = 1; 26 | } 27 | } else { 28 | while (my ($key, $value) = each(%ENV)) { 29 | print "$key=$value\n"; 30 | } 31 | } 32 | exit $rc; 33 | 34 | __END__ 35 | 36 | =pod 37 | 38 | =head1 NAME 39 | 40 | printenv - Display the environment 41 | 42 | =head1 SYNOPSIS 43 | 44 | printenv [name] 45 | 46 | =head1 DESCRIPTION 47 | 48 | printenv displays the current environment. If an argument is supplied, only the 49 | value of that variable is displayed. 50 | 51 | =head1 BUGS 52 | 53 | I has no known bugs. 54 | 55 | =head1 AUTHOR 56 | 57 | The Perl implementation of I 58 | was written by Randy Yarger, I. 59 | 60 | =head1 COPYRIGHT and LICENSE 61 | 62 | This program is copyright by Randy Yarger 1999. 63 | 64 | This program is free and open software. You may use, modify, distribute 65 | and sell this program (and any modified variants) in any way you wish, 66 | provided you do not restrict others to do the same. 67 | 68 | =cut 69 | 70 | 71 | -------------------------------------------------------------------------------- /bin/printf: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: printf 6 | Description: format and print data 7 | Author: Tom Christiansen, tchrist@perl.com 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # printf - format and print data 16 | 17 | use strict; 18 | 19 | use File::Basename qw(basename); 20 | 21 | use constant EX_SUCCESS => 0; 22 | use constant EX_FAILURE => 1; 23 | 24 | my $Program = basename($0); 25 | 26 | unless (@ARGV) { 27 | warn "usage: $Program format [argument ...]\n"; 28 | exit EX_FAILURE; 29 | } 30 | 31 | my @fmt; 32 | my $format = shift; 33 | exit EX_SUCCESS unless (length $format); 34 | @ARGV = () if (parse_fmt() == 0); 35 | do { 36 | foreach my $part (@fmt) { 37 | if ($part->[0] eq 'str') { 38 | print escape_str($part->[1]); 39 | } elsif ($part->[0] eq 'ifmt') { 40 | my $fmt = $part->[1]; 41 | my $arg = shift; 42 | $arg = 0 unless defined $arg; 43 | if ($arg =~ m/\A0x/i) { 44 | $arg = hex $arg; 45 | } 46 | printf $fmt, $arg; 47 | } elsif ($part->[0] eq 'sfmt') { 48 | my $fmt = $part->[1]; 49 | my $arg = shift; 50 | $arg = '' unless defined $arg; 51 | printf $fmt, $arg; 52 | } else { 53 | die "internal error"; 54 | } 55 | } 56 | } while (@ARGV); 57 | exit EX_SUCCESS; 58 | 59 | sub parse_fmt { 60 | my $f = $format; 61 | $f =~ s/\%c/\%\.1s/g; # standard printf: %c == 1st char 62 | 63 | my $i = 0; 64 | while (length $f) { 65 | if ($f =~ s/\A([^%]+)//) { 66 | push @fmt, [ 'str', $1 ]; 67 | } elsif ($f =~ s/\A\%\%//) { 68 | push @fmt, [ 'str', '%%' ]; 69 | } elsif ($f =~ s/\A(\%[0-9\.\-]*s)//) { 70 | push @fmt, [ 'sfmt', $1 ]; 71 | $i++; 72 | } elsif ($f =~ s/\A(\%[0-9\.\-]*[diouXx])//) { 73 | push @fmt, [ 'ifmt', $1 ]; 74 | $i++; 75 | } elsif ($f =~ s/\A(\%[0-9\.\-]*[a-zA-Z])//) { 76 | push @fmt, [ 'str', $1 ]; # unsupported 77 | } else { 78 | if ($f =~ m/\A[^\%]*(\%[\S]+)/) { 79 | warn "$Program: invalid format: '$1'\n"; 80 | exit EX_FAILURE; 81 | } 82 | die "internal error"; 83 | } 84 | } 85 | return $i; 86 | } 87 | 88 | sub oct2char { 89 | my $str = shift; 90 | my $n = oct($str) & 255; 91 | return chr($n); 92 | } 93 | 94 | sub hex2char { 95 | my $str = shift; 96 | my $n = hex($str) & 255; 97 | return chr($n); 98 | } 99 | 100 | sub escape_str { 101 | my $str = shift; 102 | $str =~ s/\\a/\a/g; 103 | $str =~ s/\\b/\b/g; 104 | $str =~ s/\\f/\f/g; 105 | $str =~ s/\\n/\n/g; 106 | $str =~ s/\\r/\r/g; 107 | $str =~ s/\\t/\t/g; 108 | $str =~ s/\\v/\x0b/g; 109 | $str =~ s/\\([0-7]{1,3})/oct2char($1)/eg; 110 | $str =~ s/\\x([0-9a-fA-F]{1,2})/hex2char($1)/eg; 111 | return $str; 112 | } 113 | 114 | __END__ 115 | 116 | =head1 NAME 117 | 118 | printf - format and print data 119 | 120 | =head1 SYNOPSIS 121 | 122 | B I [ I ... ] 123 | 124 | =head1 DESCRIPTION 125 | 126 | The B command uses the first argument as the format that describes 127 | how to print the remaining arguments. Unlike the standard 128 | printf(1) command, this one uses the Perl version. 129 | See L for details. 130 | 131 | =head1 SEE ALSO 132 | 133 | printf(3), L 134 | 135 | =head1 AUTHOR 136 | 137 | Tom Christiansen, I. 138 | 139 | =head1 COPYRIGHT and LICENSE 140 | 141 | This program is copyright (c) Tom Christiansen 1999. 142 | 143 | This program is free and open software. You may use, modify, distribute, 144 | and sell this program (and any modified variants) in any way you wish, 145 | provided you do not restrict others from doing the same. 146 | -------------------------------------------------------------------------------- /bin/pwd: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: pwd 6 | Description: working directory name 7 | Author: Kevin Meltzer, perlguy@perlguy.com 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | use Cwd qw(cwd getcwd); 18 | use Getopt::Std qw(getopts); 19 | 20 | my ($VERSION) = '1.4'; 21 | 22 | my %opt; 23 | getopts('LP', \%opt) or usage(); 24 | usage() if @ARGV; 25 | my $dir = $opt{'L'} ? cwd() : getcwd(); # default -P 26 | unless (defined $dir) { 27 | warn "pwd: $!\n"; 28 | exit 1; 29 | } 30 | if ($^O =~ m/Win32/) { 31 | $dir =~ tr/\//\\/; 32 | } 33 | print $dir . "\n"; 34 | exit; 35 | 36 | sub usage { 37 | warn "usage: pwd [-L|-P]\n"; 38 | exit 1; 39 | } 40 | 41 | __END__ 42 | 43 | =pod 44 | 45 | =head1 NAME 46 | 47 | pwd - working directory name 48 | 49 | =head1 SYNOPSIS 50 | 51 | pwd 52 | 53 | =head1 DESCRIPTION 54 | 55 | Pwd prints the pathname of the working (current) directory. 56 | 57 | =head2 OPTIONS 58 | 59 | I takes no options. 60 | 61 | =head1 ENVIRONMENT 62 | 63 | The working of I is not influenced by any environment variables. 64 | 65 | =head1 BUGS 66 | 67 | I has no known bugs. 68 | 69 | =head1 AUTHOR 70 | 71 | The Perl implementation of I 72 | was written by Kevin Meltzer, I. 73 | 74 | =head1 COPYRIGHT and LICENSE 75 | 76 | This program is copyright by Kevin Meltzer 1999. 77 | 78 | This program is free and open software. You may use, modify, distribute 79 | and sell this program (and any modified variants) in any way you wish, 80 | provided you do not restrict others to do the same. 81 | 82 | =cut 83 | 84 | 85 | -------------------------------------------------------------------------------- /bin/rain: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: rain 6 | Description: let it rain 7 | Author: Abigail, perlpowertools@abigail.be 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | my ($VERSION) = '1.2'; 18 | 19 | if (@ARGV) { 20 | require File::Basename; 21 | $0 = File::Basename::basename ($0); 22 | print "$0 (Perl bin utils) $VERSION\n"; 23 | exit; 24 | } 25 | 26 | print "/" x 72, "\n" while 1; 27 | 28 | __END__ 29 | 30 | =pod 31 | 32 | =head1 NAME 33 | 34 | rain - Let it rain 35 | 36 | =head1 SYNOPSIS 37 | 38 | rain 39 | 40 | =head1 DESCRIPTION 41 | 42 | I simulates rain. 43 | 44 | =head2 OPTIONS 45 | 46 | I does not accept options. 47 | 48 | =head1 ENVIRONMENT 49 | 50 | The working of I is not influenced by any 51 | environment variables. 52 | 53 | =head1 BUGS 54 | 55 | I does not have any known bugs. 56 | 57 | =head1 AUTHOR 58 | 59 | The Perl implementation of I 60 | was written by Abigail, I. 61 | 62 | =head1 COPYRIGHT and LICENSE 63 | 64 | This program is copyright by Abigail 1999. 65 | 66 | This program is free and open software. You may use, modify, distribute 67 | and sell this program (and any modified variants) in any way you wish, 68 | provided you do not restrict others to do the same. 69 | 70 | =cut 71 | 72 | -------------------------------------------------------------------------------- /bin/random: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: random 6 | Description: display lines at random, or exit with a random value 7 | Author: Abigail, perlpowertools@abigail.be 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | use Getopt::Std; 17 | 18 | my ($VERSION) = '1.3'; 19 | 20 | my %options; 21 | getopts('er', \%options) or usage(); 22 | my $denominator = shift; 23 | $denominator = 2 unless defined $denominator; 24 | usage() if @ARGV; 25 | usage() if $denominator =~ /\D/ || $denominator == 0; 26 | 27 | exit int rand $denominator if exists $options {e}; 28 | 29 | $| = 1 if exists $options {r}; 30 | 31 | my $frac = 1 / $denominator; 32 | 33 | while (<>) {print if $frac >= rand;} 34 | exit 0; 35 | 36 | sub usage { 37 | warn "usage: $0 [-er] [denominator]\n"; 38 | exit 1; 39 | } 40 | 41 | __END__ 42 | 43 | =pod 44 | 45 | =head1 NAME 46 | 47 | random - display lines at random, or exit with a random value 48 | 49 | =head1 SYNOPSIS 50 | 51 | random [-er] [denominator] 52 | 53 | =head1 DESCRIPTION 54 | 55 | I reads line from standard input, and displays each line on 56 | standard output which chance 1 / I. If the I<-e> option 57 | is given, I exits with a value randomly choosen from C<0> to 58 | C inclusive. If no I is given, 2 is used. 59 | 60 | =head2 OPTIONS 61 | 62 | I accepts the following options: 63 | 64 | =over 4 65 | 66 | =item -e 67 | 68 | Exit with a value randomly choosen from C<0> to C inclusive. 69 | Do not read input, or display output. 70 | 71 | =item -r 72 | 73 | Use unbuffered output. 74 | 75 | =back 76 | 77 | =head1 ENVIRONMENT 78 | 79 | The working of I is not influenced by any environment variables. 80 | 81 | =head1 BUGS 82 | 83 | There are no known bugs in I. 84 | 85 | =head1 AUTHOR 86 | 87 | The Perl implementation of I was written by Abigail, I. 88 | 89 | =head1 COPYRIGHT and LICENSE 90 | 91 | This program is copyright by Abigail 1999. 92 | 93 | This program is free and open software. You may use, copy, modify, distribute 94 | and sell this program (and any modified variants) in any way you wish, 95 | provided you do not restrict others to do the same. 96 | 97 | =cut 98 | 99 | -------------------------------------------------------------------------------- /bin/rev: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: rev 6 | Description: reverse lines of a file 7 | Author: Andy Murren, andy@murren.org 8 | License: gpl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | use strict; 15 | 16 | use File::Basename qw(basename); 17 | use Getopt::Std qw(getopts); 18 | 19 | use constant EX_SUCCESS => 0; 20 | use constant EX_FAILURE => 1; 21 | 22 | my $Program = basename($0); 23 | 24 | # unbuffer output to make it look speedier 25 | $|++; 26 | 27 | our $VERSION = '1.5'; 28 | 29 | getopts('') or usage(); 30 | my $rc = EX_SUCCESS; 31 | foreach my $file (@ARGV) { 32 | if (-d $file) { 33 | warn "$Program: '$file' is a directory\n"; 34 | $rc = EX_FAILURE; 35 | next; 36 | } 37 | my $fh; 38 | unless (open $fh, '<', $file) { 39 | warn "$Program: cannot open '$file': $!\n"; 40 | $rc = EX_FAILURE; 41 | next; 42 | } 43 | rev($fh); 44 | if ($!) { 45 | warn "$Program: '$file': $!\n"; 46 | $rc = EX_FAILURE; 47 | } 48 | unless (close $fh) { 49 | warn "$Program: cannot close '$file': $!\n"; 50 | $rc = EX_FAILURE; 51 | next; 52 | } 53 | } 54 | rev(*STDIN) unless @ARGV; 55 | exit $rc; 56 | 57 | sub rev { 58 | my $fh = shift; 59 | while (<$fh>) { 60 | chomp; 61 | my $r = reverse; 62 | print $r, $/; 63 | } 64 | } 65 | 66 | sub usage { 67 | print "usage: $Program [file ...]\n"; 68 | exit EX_FAILURE; 69 | } 70 | 71 | sub VERSION_MESSAGE { 72 | print "$Program version $VERSION\n"; 73 | exit EX_SUCCESS; 74 | } 75 | 76 | __END__ 77 | 78 | =pod 79 | 80 | =head1 NAME 81 | 82 | rev - reverse lines of a file 83 | 84 | =head1 SYNOPSIS 85 | 86 | rev [file ...] 87 | 88 | =head1 DESCRIPTION 89 | 90 | The rev utility copies the specified files to the standard output, 91 | reversing the order of characters in every line. If no files are 92 | specified, the standard input is read. 93 | 94 | =head2 OPTIONS 95 | 96 | I accepts the following options: 97 | 98 | =over 4 99 | 100 | =item --version 101 | 102 | Print version number then exit 103 | 104 | =back 105 | 106 | =head1 BUGS 107 | 108 | I has no known bugs. 109 | 110 | =head1 AUTHOR 111 | 112 | This Perl implementation of I was written by Andy Murren, 113 | I. 114 | 115 | =head1 COPYRIGHT and LICENSE 116 | 117 | This program is covered by the GNU Public License (GPL). 118 | See I for complete detail of the license. 119 | 120 | =cut 121 | -------------------------------------------------------------------------------- /bin/rmdir: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: rmdir 6 | Description: remove directories 7 | Author: Abigail, perlpowertools@abigail.be 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | use strict; 16 | 17 | use File::Basename qw(basename); 18 | use File::Spec; 19 | use Getopt::Std qw(getopts); 20 | 21 | use constant EX_SUCCESS => 0; 22 | use constant EX_FAILURE => 1; 23 | 24 | my ($VERSION) = '1.3'; 25 | my $Program = basename($0); 26 | 27 | my $rc = EX_SUCCESS; 28 | my %opt; 29 | if (!getopts('p', \%opt) || scalar(@ARGV) == 0) { 30 | warn "usage: $Program [-p] directory ...\n"; 31 | exit EX_FAILURE; 32 | } 33 | foreach my $directory (@ARGV) { 34 | next unless remove($directory); 35 | if ($opt{'p'}) { 36 | my @parts = File::Spec->splitdir($directory); 37 | my @seq = 0 .. (scalar(@parts) - 2); 38 | for (reverse @seq) { 39 | my $d = File::Spec->catfile(@parts[0 .. $_]); 40 | next if length($d) == 0; # absolute path 41 | remove($d); 42 | } 43 | } 44 | } 45 | exit $rc; 46 | 47 | sub remove { 48 | my $dir = shift; 49 | unless (rmdir $dir) { 50 | warn "$Program: failed to remove '$dir': $!\n"; 51 | $rc = EX_FAILURE; 52 | return 0; 53 | } 54 | return 1; 55 | } 56 | 57 | __END__ 58 | 59 | =pod 60 | 61 | =head1 NAME 62 | 63 | rmdir - remove directories 64 | 65 | =head1 SYNOPSIS 66 | 67 | rmdir [-p] directory ... 68 | 69 | =head1 DESCRIPTION 70 | 71 | I removes the directories which are given as argument, if 72 | they are empty. Trying to remove a non-empty directory is regarded 73 | as an error. 74 | 75 | =head2 OPTIONS 76 | 77 | I accepts the following options: 78 | 79 | =over 4 80 | 81 | =item -p 82 | 83 | Make I treat the arguments as path names, of which all non-empty 84 | components will be removed. Leftmost components will be removed first. 85 | 86 | =back 87 | 88 | =head1 ENVIRONMENT 89 | 90 | The working of I is not influenced by any environment variables. 91 | 92 | =head1 BUGS 93 | 94 | I does not have any known bugs. 95 | 96 | =head1 STANDARDS 97 | 98 | This I implementation is compatible with the B implementation, 99 | which is expected to be compatible with the B 100 | (aka B) standard. 101 | 102 | =head1 AUTHOR 103 | 104 | The Perl implementation of I was written by Abigail, I. 105 | 106 | =head1 COPYRIGHT and LICENSE 107 | 108 | This program is copyright by Abigail 1999. 109 | 110 | This program is free and open software. You may use, copy, modify, distribute 111 | and sell this program (and any modified variants) in any way you wish, 112 | provided you do not restrict others to do the same. 113 | 114 | =cut 115 | 116 | -------------------------------------------------------------------------------- /bin/rot13: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use warnings; 3 | use strict; 4 | 5 | =begin metadata 6 | 7 | Name: rot13 8 | Description: Rotate the Latin letters by 13 positions 9 | Author: Mark Rosetta (@marked on GitHub) 10 | Contributor: brian d foy, bdfoy@cpan.org 11 | License: artistic2 12 | 13 | =end metadata 14 | 15 | =cut 16 | 17 | while ( <> ) { 18 | tr/A-Za-z/N-ZA-Mn-za-m/; 19 | print; 20 | }; 21 | -------------------------------------------------------------------------------- /bin/seq: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =encoding utf8 4 | 5 | =begin metadata 6 | 7 | Name: seq 8 | Description: print a numeric sequence 9 | Author: Michael Mikonos 10 | License: artistic2 11 | 12 | =end metadata 13 | 14 | =cut 15 | 16 | use strict; 17 | 18 | use File::Basename qw(basename); 19 | use POSIX qw(floor); 20 | 21 | use constant EX_SUCCESS => 0; 22 | use constant EX_FAILURE => 1; 23 | 24 | my $Program = basename($0); 25 | 26 | my $begin = 1; 27 | my $step = 1; 28 | my $ender; 29 | my $format = "%g"; 30 | my $term = "\n"; 31 | 32 | sub usage { 33 | warn "usage: $Program [-f format] [-s string] [begin [step]] end\n"; 34 | exit EX_FAILURE; 35 | } 36 | 37 | while (@ARGV && $ARGV[0] =~ /^-/) { 38 | my $opt = shift; 39 | if ($opt eq '--') { 40 | last; 41 | } elsif ($opt eq '-s') { 42 | $term = shift; 43 | } elsif ($opt eq '-f') { 44 | $format = shift; 45 | } elsif ($opt =~ m/\A\-?[0-9]/) { 46 | unshift @ARGV, $opt; 47 | last; 48 | } else { 49 | warn "$Program: unexpected option: '$opt'\n"; 50 | usage(); 51 | } 52 | } 53 | if (@ARGV == 0) { 54 | usage(); 55 | } elsif (@ARGV == 1) { 56 | $ender = getnum($ARGV[0]); 57 | } elsif (@ARGV == 2) { 58 | $begin = getnum($ARGV[0]); 59 | $ender = getnum($ARGV[1]); 60 | } elsif (@ARGV == 3) { 61 | $begin = getnum($ARGV[0]); 62 | $step = getnum($ARGV[1]); 63 | $ender = getnum($ARGV[2]); 64 | } else { 65 | warn "$Program: extra argument '$ARGV[3]'\n"; 66 | usage(); 67 | } 68 | 69 | if ($step == 0) { 70 | warn "$Program: illegal step value of zero\n"; 71 | exit EX_FAILURE; 72 | } 73 | if ($ender < $begin) { 74 | if (@ARGV != 3) { 75 | $step = -$step; 76 | } elsif ($step > 0) { 77 | warn "$Program: needs negative decrement\n"; 78 | exit EX_FAILURE; 79 | } 80 | } else { 81 | if ($step < 0) { 82 | warn "$Program: needs positive increment\n"; 83 | exit EX_FAILURE; 84 | } 85 | } 86 | 87 | my $head = 1; 88 | my $count = floor(($ender - $begin) / $step); 89 | for (0 .. $count) { 90 | if ($head) { 91 | $head = 0; 92 | } else { 93 | print $term; 94 | } 95 | printf $format, $begin + $_ * $step; 96 | } 97 | print "\n"; 98 | exit EX_SUCCESS; 99 | 100 | sub getnum { 101 | my $n = shift; 102 | if ($n !~ m/\A[\+\-]?[0-9]+(\.[0-9]+)?\Z/) { 103 | warn "$Program: invalid number '$n'\n"; 104 | exit EX_FAILURE; 105 | } 106 | return $n; 107 | } 108 | 109 | __END__ 110 | 111 | =head1 NAME 112 | 113 | seq - print a numeric sequence 114 | 115 | =head1 SYNOPSIS 116 | 117 | seq [OPTIONS] LAST 118 | seq [OPTIONS] FIRST LAST 119 | seq [OPTIONS] FIRST INCR LAST 120 | 121 | =head1 DESCRIPTION 122 | 123 | seq writes a list of numbers to standard output separated by a newline character. 124 | If only LAST is provided the sequence starts from 1 and the increment is 1. 125 | LAST may be negative, in which case the sequence starts from 1 with the increment of -1. 126 | 127 | When only FIRST and LAST are specified the increment will be either 1 or -1 based on whether FIRST is greater. 128 | Sequences are inclusive of FIRST and LAST, so "seq 3 3" results in the sequence "3". 129 | 130 | When an increment is needed other than 1 or -1, the INCR argument should be used. 131 | Zero is not a valid increment. 132 | Positive numbers may optionally include a '+' prefix. 133 | Floating point numbers may be entered in decimal notation (e.g. 0.2223). 134 | 135 | =head2 OPTIONS 136 | 137 | The following options are available: 138 | 139 | =over 4 140 | 141 | =item -f FORMAT 142 | 143 | Set a printf format specifier instead of the default '%g' 144 | 145 | =item -s STRING 146 | 147 | Separate each number with STRING instead of the newline character 148 | 149 | =back 150 | 151 | =head1 BUGS 152 | 153 | Corrupt printf format specifiers may be entered. 154 | 155 | =head1 AUTHOR 156 | 157 | Written by Michael Mikonos. 158 | 159 | =head1 COPYRIGHT 160 | 161 | Copyright (c) 2023 Michael Mikonos. 162 | 163 | This code is licensed under the Artistic License 2. 164 | 165 | =cut 166 | -------------------------------------------------------------------------------- /bin/shar: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: shar 6 | Description: create a shell archive of files 7 | Author: Rich Salz, salzr@certo.com, rsalz@osf.org, rsalz@bbn.com 8 | License: public domain 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | use strict; 15 | 16 | use File::Basename qw(basename); 17 | use Getopt::Std qw(getopts); 18 | 19 | use constant EX_SUCCESS => 0; 20 | use constant EX_FAILURE => 1; 21 | 22 | my $Program = basename($0); 23 | 24 | getopts('') or usage(); 25 | @ARGV or usage(); 26 | 27 | print '# --cut here-- 28 | # To extract, remove everything before the "cut here" line 29 | # and run the command "sh file". 30 | '; 31 | 32 | my $done = 0; 33 | ARGUMENT: for my $f ( @ARGV ) { 34 | if (length($f) == 0) { 35 | warn "$Program: empty file name\n"; 36 | next ARGUMENT; 37 | } 38 | my $quoted = quotefile($f); 39 | if (-d $f) { 40 | print "echo x - $quoted/\n"; 41 | print "mkdir -p $quoted\n"; 42 | $done++; 43 | next ARGUMENT; 44 | } 45 | my $fh; 46 | unless (open $fh, '<', $f) { 47 | warn "$Program: can't open '$f': $!\n"; 48 | next ARGUMENT; 49 | } 50 | binmode $fh; 51 | 52 | print "echo x - $quoted\n"; 53 | if (-B $f) { 54 | my $mode = (stat $f)[2]; 55 | $mode = (join '', 0, ($mode&0700)>>6, ($mode&0070)>>3, ($mode&0007)); 56 | print "uudecode <<'FUNKY_STUFF'\n"; 57 | print "begin $mode $f\n"; 58 | my $block; 59 | print pack 'u', $block while read $fh, $block, 45; 60 | print "`\nend\n"; 61 | } else { 62 | print "sed -e 's/^X//' >$quoted <<'FUNKY_STUFF'\n"; 63 | print 'X', $_ while ( <$fh> ); 64 | } 65 | print "FUNKY_STUFF\n"; 66 | unless (close $fh) { 67 | warn "$Program: can't close '$f': $!\n"; 68 | next ARGUMENT; 69 | } 70 | $done++; 71 | } 72 | if ($done == 0) { 73 | warn "$Program: no input files were processed\n"; 74 | exit EX_FAILURE; 75 | } 76 | exit EX_SUCCESS; 77 | 78 | sub usage { 79 | warn "usage: $Program file...\n"; 80 | exit EX_FAILURE; 81 | } 82 | 83 | sub quotefile { 84 | my $name = shift; 85 | if ($name =~ m/[\s\'\"\(\)\[\]\{\}\;\:\*]/) { 86 | $name =~ s/\"/\\\"/g; 87 | $name = "\"$name\""; 88 | } 89 | return $name; 90 | } 91 | 92 | __END__ 93 | 94 | =head1 NAME 95 | 96 | shar - create a shell archive of files 97 | 98 | =head1 SYNOPSIS 99 | 100 | B file... 101 | 102 | =head1 DESCRIPTION 103 | 104 | B reads input files and writes a shell archive to standard output. 105 | The shell archive is a shell script, and executing it will recreate the I. 106 | File permissions are not preserved for archived files. 107 | Extracted files are created with the default file permissions and owner. 108 | Directories will be recreated, but directory arguments must be provided before 109 | the files they contain. 110 | 111 | =head1 SEE ALSO 112 | 113 | B 114 | 115 | =head1 AUTHOR 116 | 117 | Rich Salz | salzr@certo.com | rsalz@osf.org | rsalz@bbn.com 118 | 119 | =head1 COPYRIGHT 120 | 121 | This code is released to the public domain. 122 | 123 | =cut 124 | -------------------------------------------------------------------------------- /bin/sleep: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: sleep 6 | Description: suspend execution for a number of seconds 7 | Author: Randy Yarger, randy.yarger@nextel.com 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | use strict; 15 | 16 | use File::Basename qw(basename); 17 | use Getopt::Std qw(getopts); 18 | 19 | use constant EX_SUCCESS => 0; 20 | use constant EX_FAILURE => 1; 21 | 22 | my $Program = basename($0); 23 | my ($VERSION) = '1.203'; 24 | 25 | getopts('') or usage(); 26 | my $seconds = shift; 27 | unless (defined $seconds) { 28 | warn "$Program: missing operand\n"; 29 | usage(); 30 | } 31 | if (@ARGV) { 32 | warn "$Program: extra operand `$ARGV[0]'\n"; 33 | usage(); 34 | } 35 | if ($seconds !~ m/\A[0-9]+\z/) { 36 | warn "$Program: invalid time interval `$seconds'\n"; 37 | exit EX_FAILURE; 38 | } 39 | sleep $seconds; 40 | exit EX_SUCCESS; 41 | 42 | sub usage { 43 | warn "usage: $Program SECONDS\n"; 44 | exit EX_FAILURE; 45 | } 46 | 47 | __END__ 48 | 49 | =pod 50 | 51 | =head1 NAME 52 | 53 | sleep - suspend execution for a number of seconds 54 | 55 | =head1 SYNOPSIS 56 | 57 | sleep I 58 | 59 | =head1 DESCRIPTION 60 | 61 | I waits for a number of seconds, then exits successfully. 62 | The argument is taken as a decimal number with no fractional part. 63 | 64 | =head1 ENVIRONMENT 65 | 66 | The working of I is not influenced by any environment variables. 67 | 68 | =head1 BUGS 69 | 70 | I has no known bugs. 71 | 72 | =head1 AUTHOR 73 | 74 | The Perl implementation of I 75 | was written by Randy Yarger, I. 76 | 77 | =head1 COPYRIGHT and LICENSE 78 | 79 | This program is copyright by Randy Yarger 1999. 80 | 81 | This program is free and open software. You may use, modify, distribute 82 | and sell this program (and any modified variants) in any way you wish, 83 | provided you do not restrict others to do the same. 84 | 85 | =cut 86 | 87 | -------------------------------------------------------------------------------- /bin/strings: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: strings 6 | Description: extract strings 7 | Author: Nathan Scott Thompson, quimby at city-net dot com 8 | License: 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # Copyright 1999 Nathan Scott Thompson 16 | 17 | =head1 NAME 18 | 19 | strings - extract strings 20 | 21 | =head1 SYNOPSIS 22 | 23 | strings [-afo] [-n length] [-t {d|o|x}] [file ...] 24 | 25 | =head1 DESCRIPTION 26 | 27 | C prints strings gleaned from the given files 28 | (or from standard input.) By default strings of less than 4 characters 29 | are ignored. A string is considered to be any sequence of graphical ASCII 30 | characters (plus space and tab). 31 | 32 | Options: 33 | 34 | -f Print the file name with each string. 35 | 36 | -n length Set the minimum length of strings to print; 4 by default. 37 | 38 | -o Print each string with the octal offset in the file. 39 | (Same as -to). 40 | 41 | -t {d|o|x} Print each string with the offset in the file; 42 | specify decimal, octal or hexadecimal respectively. 43 | 44 | The -a option is included for compatibility with older versions but does 45 | nothing. 46 | 47 | =head1 BUGS 48 | 49 | Things are seldom what they seem, 50 | Skim milk masquerades as cream; 51 | Highlows pass as patent leathers; 52 | Jackdaws strut in peacock's feathers. 53 | 54 | =cut 55 | 56 | use strict; 57 | 58 | use File::Basename qw(basename); 59 | use Getopt::Std qw(getopts); 60 | 61 | use vars qw($opt_a $opt_f $opt_o $opt_n $opt_t); 62 | 63 | use constant EX_SUCCESS => 0; 64 | use constant EX_FAILURE => 1; 65 | 66 | my $Program = basename($0); 67 | 68 | sub usage { 69 | warn "usage: $Program [-afo] [-n length] [-t {d|o|x}] [file ...]\n"; 70 | exit EX_FAILURE; 71 | } 72 | 73 | getopts( 'afon:t:' ) or usage(); 74 | if (defined $opt_n) { 75 | if ($opt_n !~ m/\A[0-9]+\Z/ || $opt_n == 0) { 76 | warn "$Program: invalid minimum string length '$opt_n'\n"; 77 | exit EX_FAILURE; 78 | } 79 | } else { 80 | $opt_n = 4; 81 | } 82 | 83 | if ($opt_o) { 84 | $opt_t = 'o'; 85 | } elsif (defined $opt_t) { 86 | my %EXPECT = ( 87 | 'd' => 1, 88 | 'o' => 1, 89 | 'x' => 1, 90 | ); 91 | usage() unless $EXPECT{$opt_t}; 92 | } 93 | my $offset_format = "\%07$opt_t "; 94 | 95 | # Consider all graphic characters plus space and tab to be printable. 96 | # Escape all punctuation characters out of paranoia. 97 | 98 | my $punctuation = join '\\', split //, q/`~!@#$%^&*()-+={}|[]\:";'<>?,.\//; 99 | my $printable = '\w \t' . $punctuation; 100 | my $chunksize = 4096; # whatever 101 | 102 | for my $filename ( @ARGV ) 103 | { 104 | next if -d $filename; 105 | my $in; 106 | unless (open $in, '<', $filename) { 107 | warn "$Program: Can't open '$filename': $!\n"; 108 | exit EX_FAILURE; 109 | } 110 | binmode $in; 111 | scanfile($in, $filename); 112 | close $in; 113 | } 114 | unless (@ARGV) { 115 | scanfile(*STDIN, ''); 116 | } 117 | exit EX_SUCCESS; 118 | 119 | sub scanfile { 120 | my ($fh, $filename) = @_; 121 | my $offset = 0; 122 | 123 | while ($_ or read($fh, $_, $chunksize)) 124 | { 125 | $offset += length($1) if s/^([^$printable]+)//o; 126 | my $string = ''; 127 | 128 | do { 129 | $string .= $1 if s/^([$printable]+)//o; 130 | } until ($_ or !read($fh, $_, $chunksize)); 131 | 132 | if ( length($string) >= $opt_n ) 133 | { 134 | print $filename, ':' if $opt_f; 135 | printf $offset_format, $offset if $opt_t; 136 | print $string, "\n"; 137 | } 138 | $offset += length($string); 139 | } 140 | } 141 | -------------------------------------------------------------------------------- /bin/tee: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: tee 6 | Description: pipe fitting 7 | Author: Tom Christiansen, tchrist@perl.com 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # 16 | # tee clone that groks process tees (should work even with old perls) 17 | # Tom Christiansen 18 | # 6 June 91 19 | 20 | use strict; 21 | 22 | use Getopt::Std qw(getopts); 23 | use IO::File; 24 | 25 | our $VERSION = '1.0'; 26 | 27 | my %opt; 28 | getopts('ai', \%opt) or die "usage: tee [-ai] [file ...]\n"; 29 | $SIG{'INT'} = 'IGNORE' if $opt{'i'}; 30 | $| = 1; 31 | 32 | my $mode = $opt{'a'} ? 'a' : 'w'; 33 | my $status = 0; 34 | my $default_fd = fileno(*STDOUT); 35 | my %fh = ($default_fd => { 36 | 'name' => 'standard output', 37 | 'fh' => *STDOUT, 38 | }); 39 | 40 | for (@ARGV) { 41 | if (-d $_) { 42 | warn "$0: '$_' is a directory\n"; 43 | $status++; 44 | next; 45 | } 46 | my $fh = IO::File->new($_, $mode); 47 | unless (defined $fh) { 48 | warn "$0: cannot open $_: $!\n"; # like sun's; i prefer die 49 | $status++; 50 | next; 51 | } 52 | my $fd = fileno $fh; 53 | $fh{$fd}->{'name'} = $_; 54 | $fh{$fd}->{'fh'} = $fh; 55 | } 56 | while () { 57 | for my $fd (keys %fh) { 58 | my $n = syswrite $fh{$fd}->{'fh'}, $_; 59 | unless (defined $n) { 60 | warn sprintf("%s: write '%s': %s\n", $0, $fh{$fd}->{'name'}, $!); 61 | delete $fh{$fd}; 62 | $status++; 63 | } 64 | } 65 | } 66 | for my $fd (keys %fh) { 67 | unless (close $fh{$fd}->{'fh'}) { 68 | warn sprintf("%s: close '%s': %s\n", $0, $fh{$fd}->{'name'}, $!); 69 | $status++; 70 | } 71 | } 72 | exit $status; 73 | 74 | sub VERSION_MESSAGE { 75 | print "tee version $VERSION\n"; 76 | exit 0; 77 | } 78 | 79 | __END__ 80 | 81 | =encoding utf8 82 | 83 | =head1 NAME 84 | 85 | tee - pipe fitting 86 | 87 | =head1 SYNOPSIS 88 | 89 | tee [-ai] [file ...] 90 | 91 | =head1 DESCRIPTION 92 | 93 | tee reads data from standard input, copying it to standard output 94 | and to any files given as arguments. If no file arguments are provided, 95 | tee behaves like the cat utility and copies only to standard output. 96 | Files are opened in write mode by default, and output is not buffered. 97 | 98 | =head2 OPTIONS 99 | 100 | The following options are available: 101 | 102 | =over 4 103 | 104 | =item -a 105 | 106 | Append output to the files instead of overwriting them 107 | 108 | =item -i 109 | 110 | Ignore the SIGINT signal 111 | 112 | =back 113 | 114 | =head1 EXIT STATUS 115 | 116 | tee exits 0 on success, and >0 to indicate an error 117 | -------------------------------------------------------------------------------- /bin/time: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =begin metadata 4 | 5 | Name: time 6 | Description: times the execution of a command 7 | Author: dkulp 8 | License: perl 9 | 10 | =end metadata 11 | 12 | =cut 13 | 14 | 15 | # 16 | # time - report the time running a sub-process 17 | 18 | use Benchmark; 19 | 20 | $t0 = Benchmark->new; 21 | $rc = system(@ARGV); 22 | $t1 = Benchmark->new; 23 | $td = timediff($t1,$t0); 24 | ($real, $child_user, $child_system) = @$td[0,3,4]; 25 | 26 | # I'm pretty sure this is POSIX format 27 | printf STDERR "\nreal %.2f\nuser %.2f\nsys %.2f\n", 28 | $real, $child_user, $child_system; 29 | 30 | $rc &= 0xffff; 31 | if ($rc == 0xff00) { exit 127; } else { exit ($rc >> 8); } 32 | 33 | __END__ 34 | 35 | =pod 36 | 37 | =head1 NAME 38 | 39 | time - times the execution of a command 40 | 41 | =head1 SYNOPSIS 42 | 43 | time command [argument ...] 44 | 45 | =head1 DESCRIPTION 46 | 47 | The B