diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile new file mode 100644 index 00000000000..7cf5a1b7e5c --- /dev/null +++ b/.devcontainer/Dockerfile @@ -0,0 +1,15 @@ +FROM mcr.microsoft.com/devcontainers/base:bookworm + +# taken from: https://github.com/LMS-Community/slimserver-platforms/blob/public/9.1/Docker/Dockerfile + +# Set environment variables +ENV DEBIAN_FRONTEND=noninteractive +ENV LC_ALL="C.UTF-8" LANG="en_US.UTF-8" LANGUAGE="en_US.UTF-8" + + +# Install packages +RUN sudo apt-get update -qq && \ + sudo apt-get install --no-install-recommends -qy procps psmisc wget curl perl tzdata libcrypt-blowfish-perl libwww-perl libfont-freetype-perl liblinux-inotify2-perl \ + libdata-dump-perl libio-socket-ssl-perl libnet-ssleay-perl libcrypt-ssleay-perl libcrypt-openssl-rsa-perl libssl-dev libgomp1 libasound2 lame opus-tools && \ + sudo apt-get clean -qy && \ + sudo rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json new file mode 100644 index 00000000000..711cda1ce87 --- /dev/null +++ b/.devcontainer/devcontainer.json @@ -0,0 +1,36 @@ +// For format details, see https://aka.ms/devcontainer.json. For config options, see the +// README at: https://github.com/devcontainers/templates/tree/main/src/debian +{ + "name": "Lyrion Debian devcontainer", + // Or use a Dockerfile or Docker Compose file. More info: https://containers.dev/guide/dockerfile + //"image": "mcr.microsoft.com/devcontainers/base:bookworm", + "dockerComposeFile": "docker-compose.yml", + "service": "lyrion-devcontainer", + "workspaceFolder": "/workspaces/${localWorkspaceFolderBasename}", + // Features to add to the dev container. More info: https://containers.dev/features. + // "features": {}, + // Use 'forwardPorts' to make a list of ports inside the container available locally. + "forwardPorts": [ + 9000, + 3483, + 9090 + ], + "portsAttributes": { + "9000": { + "label": "web interface", + "protocol": "http" + }, + "3483": { + "label": "SlimProto" + }, + "9090": { + "label": "CLI" + } + }, + // Use 'postCreateCommand' to run commands after the container is created. + "postCreateCommand": "/workspaces/slimserver/.devcontainer/post-create.sh" + // Configure tool-specific properties. + // "customizations": {}, + // Uncomment to connect as root instead. More info: https://aka.ms/dev-containers-non-root. + // "remoteUser": "root" +} \ No newline at end of file diff --git a/.devcontainer/docker-compose.yml b/.devcontainer/docker-compose.yml new file mode 100644 index 00000000000..48ec338bdcc --- /dev/null +++ b/.devcontainer/docker-compose.yml @@ -0,0 +1,16 @@ +version: '3.11' + +services: + lyrion-devcontainer: + # add this line so we can connect to the host machine + build: + context: . + dockerfile: Dockerfile + volumes: + - lyrion-dev-volume:/workspace + + # Overrides default command so things don't shut down after the process ends. + command: sleep infinity + +volumes: + lyrion-dev-volume: \ No newline at end of file diff --git a/.devcontainer/post-create.sh b/.devcontainer/post-create.sh new file mode 100755 index 00000000000..9ec2d65a4a9 --- /dev/null +++ b/.devcontainer/post-create.sh @@ -0,0 +1,21 @@ +#!/bin/bash +set -e + +# get current git branch +BRANCH="$(git rev-parse --abbrev-ref HEAD)" + +URL_BRANCH="https://raw.githubusercontent.com/LMS-Community/slimserver-platforms/${BRANCH}/Docker/Slim-Utils-OS-Custom.pm" +URL_HEAD="https://raw.githubusercontent.com/LMS-Community/slimserver-platforms/HEAD/Docker/Slim-Utils-OS-Custom.pm" +TARGET_FILE="/workspaces/slimserver/Slim/Utils/OS/Custom.pm" + +echo "Detected branch: ${BRANCH}" +echo "Trying branch-specific file..." + +# Try downloading branch version +if curl -fSL "$URL_BRANCH" -o "$TARGET_FILE"; then + echo "Downloaded branch version from: $URL_BRANCH" +else + echo "Branch file not found, falling back to HEAD..." + curl -fSL "$URL_HEAD" -o "$TARGET_FILE" + echo "Downloaded latest version from: $URL_HEAD" +fi \ No newline at end of file diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md index b186efb9571..87ad15a79e9 100644 --- a/.github/ISSUE_TEMPLATE/bug_report.md +++ b/.github/ISSUE_TEMPLATE/bug_report.md @@ -25,10 +25,12 @@ If applicable, add screenshots to help explain your problem. **System Information (please complete the following information):** - OS on which you're running LMS: [e.g. pCP 10] + - Hardware on which you're running LMS (x86_64, aarch64, ARM, ...) - Web skin used: [e.g. Material, Default] - - Browser [e.g. chrome, safari] - - LMS Version [e.g. 22] + - Browser [e.g. Chrome, Safari] + - LMS Version - Player(s) involved + - Addition information from the Settings/Information header section **Additional context** Add any other context about the problem here. E.g. a `server.log` or `scanner.log` snippet (see Settings/Information in your LMS) diff --git a/.github/actions/build/action.yaml b/.github/actions/build/action.yaml index e74a8112e0e..47d36701eb7 100644 --- a/.github/actions/build/action.yaml +++ b/.github/actions/build/action.yaml @@ -13,6 +13,16 @@ inputs: description: The key ID to use to upload to S3 AWS_SECRET_ACCESS_KEY: description: The secret to use to upload to S3 + SIGNPATH_API_TOKEN: + description: The SignPath API token to use for code signing + SIGNPATH_ORG_ID: + description: The SignPath organization ID to use for code signing + SIGNPATH_PROJECT_SLUG: + description: The SignPath project slug to use for code signing + SIGNPATH_SIGNING_POLICY_SLUG: + description: The SignPath signing policy slug to use for code signing + SIGNPATH_ARTIFACT_CONFIG_SLUG: + description: The SignPath artifact config slug to use for code signing runs: using: composite @@ -33,7 +43,7 @@ runs: - name: Check out LMS platform code - uses: actions/checkout@v4 + uses: actions/checkout@v6 with: repository: ${{ github.repository_owner }}/slimserver-platforms path: platforms @@ -42,7 +52,7 @@ runs: - name: Check out pCP platform code if: ${{ startsWith(inputs.build-params, 'pcp') }} - uses: actions/checkout@v4 + uses: actions/checkout@v6 with: repository: picoreplayer/lms-update-script path: platforms/pcp @@ -120,12 +130,14 @@ runs: fi - name: Cache s5cmd - uses: actions/cache@v4 + if: ${{ !startsWith(inputs.build-params, 'docker') }} + uses: actions/cache@v5 with: key: s5cmd-${{ runner.os }} path: ${{ runner.temp }}/s5cmd-bin - name: Check if s5cmd is installed + if: ${{ !startsWith(inputs.build-params, 'docker') }} id: check-s5cmd continue-on-error: true shell: bash @@ -151,11 +163,35 @@ runs: - name: Archive artifacts if: ${{ !startsWith(inputs.build-params, 'docker') }} - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@v6 + id: upload-artifact with: name: ${{ inputs.build-params }} path: publish + - name: Prepare Windows release signing + if: ${{ startsWith(inputs.build-params, 'win64') && inputs.build-type == 'release' }} + uses: signpath/github-action-submit-signing-request@v2 + with: + api-token: '${{ inputs.SIGNPATH_API_TOKEN }}' + organization-id: '${{ inputs.SIGNPATH_ORG_ID }}' + project-slug: '${{ inputs.SIGNPATH_PROJECT_SLUG }}' + signing-policy-slug: '${{ inputs.SIGNPATH_SIGNING_POLICY_SLUG }}' + artifact-configuration-slug: '${{ inputs.SIGNPATH_ARTIFACT_CONFIG_SLUG }}' + github-artifact-id: '${{ steps.upload-artifact.outputs.artifact-id }}' + wait-for-completion: true + output-artifact-directory: publish + + - name: Calculate hash for signed Windows binary + if: ${{ startsWith(inputs.build-params, 'win64') && inputs.build-type == 'release' }} + shell: bash + run: | + cd publish + for f in LyrionMusicServer-*exe; + do + md5sum $f > $f.md5 + done + - name: Upload artifacts to R2 if: ${{ !startsWith(inputs.build-params, 'docker') && github.repository_owner == 'LMS-Community' }} shell: bash diff --git a/.github/workflows/00_build.yaml b/.github/workflows/00_build.yaml index b91059f0952..5ce6b5a7b60 100644 --- a/.github/workflows/00_build.yaml +++ b/.github/workflows/00_build.yaml @@ -35,7 +35,7 @@ jobs: steps: # we must check out here, as otherwise the build action is not available - name: Check out LMS code - uses: actions/checkout@v4 + uses: actions/checkout@v6 with: path: server ref: ${{ inputs.branch }} @@ -89,16 +89,17 @@ jobs: steps: # we must check out here, as otherwise the build action is not available - name: Check out LMS code - uses: actions/checkout@v4 + uses: actions/checkout@v6 with: path: server ref: ${{ inputs.branch }} - name: Prepare build environment if: ${{ matrix.flavour[0] != 'tarball' && matrix.flavour[0] != 'pcp' }} - run: | - sudo apt update - sudo apt install -y apt-transport-https debhelper devscripts + uses: awalsh128/cache-apt-pkgs-action@latest + with: + packages: apt-transport-https debhelper devscripts + version: 1 - name: Launch build process uses: ./server/.github/actions/build @@ -115,7 +116,7 @@ jobs: steps: # we must check out here, as otherwise the build action is not available - name: Check out LMS code - uses: actions/checkout@v4 + uses: actions/checkout@v6 with: path: server ref: ${{ inputs.branch }} @@ -148,7 +149,7 @@ jobs: steps: # we must check out here, as otherwise the build action is not available - name: Check out LMS code - uses: actions/checkout@v4 + uses: actions/checkout@v6 with: path: server ref: ${{ inputs.branch }} @@ -160,6 +161,21 @@ jobs: build-type: ${{ inputs.build_type }} AWS_KEY_ID: ${{ secrets.R2_KEY_ID }} AWS_SECRET_ACCESS_KEY: ${{ secrets.R2_SECRET_ACCESS_KEY }} + SIGNPATH_API_TOKEN: ${{ secrets.SIGNPATH_API_TOKEN }} + SIGNPATH_ORG_ID: ${{ vars.SIGNPATH_ORG_ID }} + SIGNPATH_PROJECT_SLUG: ${{ vars.SIGNPATH_PROJECT_SLUG }} + SIGNPATH_SIGNING_POLICY_SLUG: ${{ vars.SIGNPATH_SIGNING_POLICY_SLUG }} + SIGNPATH_ARTIFACT_CONFIG_SLUG: ${{ vars.SIGNPATH_ARTIFACT_CONFIG_SLUG }} + + - name: Archive signed Windows artifact + # we only sign for release builds - no need to do this for nightlies + if: ${{ inputs.build-type == 'release' }} + # needs to be run here as the above build action can't run upload twice + uses: actions/upload-artifact@v6 + id: upload-artifact + with: + name: win64-signed + path: publish/ updateRepoFile: name: Trigger repository file update diff --git a/.github/workflows/00_smoketest.yaml b/.github/workflows/00_smoketest.yaml index c86d6b82ee6..0f879e164ab 100644 --- a/.github/workflows/00_smoketest.yaml +++ b/.github/workflows/00_smoketest.yaml @@ -18,13 +18,19 @@ jobs: exit 1 fi - - uses: actions/checkout@v4 + - uses: actions/checkout@v6 - name: Install dependencies + if: ${{ !env.ACT }} + uses: awalsh128/cache-apt-pkgs-action@latest + with: + packages: libio-socket-ssl-perl libnet-ssleay-perl netcat-traditional + version: 1 + + - name: Install dependencies (ACT fallback) + if: ${{ env.ACT }} run: | - if [ "$ACT" == "true" ]; then - sudo apt-get update - fi + sudo apt-get update sudo apt-get install -y libio-socket-ssl-perl libnet-ssleay-perl netcat-traditional - name: Test Strings File diff --git a/.github/workflows/close-stale-issues.yaml b/.github/workflows/close-stale-issues.yaml index 6b56bb0642a..feb3ea6081e 100644 --- a/.github/workflows/close-stale-issues.yaml +++ b/.github/workflows/close-stale-issues.yaml @@ -9,14 +9,18 @@ jobs: runs-on: ubuntu-latest permissions: issues: write + pull-requests: write steps: - - uses: actions/stale@v9 + - uses: actions/stale@v10 with: days-before-issue-stale: 720 days-before-issue-close: 14 stale-issue-label: "stale" stale-issue-message: ":warning: This issue is stale because it has been open for 720 days with no activity. Please chime in if you want to keep it alive." close-issue-message: ":no_entry: This issue was closed because it has been inactive for 14 days since being marked as stale." - days-before-pr-stale: -1 - days-before-pr-close: -1 + days-before-pr-stale: 720 + days-before-pr-close: 14 + stale-pr-label: "stale" + stale-pr-message: ":warning: This pull request is stale because it has been open for 720 days with no activity. Please chime in if you want to keep it alive." + close-pr-message: ":no_entry: This pull request was closed because it has been inactive for 14 days since being marked as stale." repo-token: ${{ secrets.GITHUB_TOKEN }} diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000000..7b198c53e5f --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +# Ignore custom OS module as this is installed in devcontainer and not part of this repo +Slim/Utils/OS/Custom.pm + +# Ignore cache, logs and prefs files +Cache/* +Logs/* +prefs/* +Plugins/* diff --git a/CPAN/Proc/Background.pm b/CPAN/Proc/Background.pm index 75c7d32e2d8..e43c38747cb 100644 --- a/CPAN/Proc/Background.pm +++ b/CPAN/Proc/Background.pm @@ -1,23 +1,19 @@ -# Proc::Background: Generic interface to background process management. -# -# Copyright (C) 1998-2002 Blair Zajac. All rights reserved. - package Proc::Background; +# ABSTRACT: Generic interface to Unix and Win32 background process management require 5.004_04; use strict; use Exporter; use Carp; use Cwd; - -use vars qw(@ISA $VERSION @EXPORT_OK); -@ISA = qw(Exporter); -@EXPORT_OK = qw(timeout_system); -$VERSION = sprintf '%d.%02d', '$Revision: 1.08 $' =~ /(\d+)\.(\d+)/; +use Scalar::Util; +@Proc::Background::ISA = qw(Exporter); +@Proc::Background::EXPORT_OK = qw(timeout_system); # Determine if the operating system is Windows. my $is_windows = $^O eq 'MSWin32'; +my $weaken_subref = Scalar::Util->can('weaken'); # Set up a regular expression that tests if the path is absolute and # if it has a directory separator in it. Also create a list of file @@ -25,24 +21,27 @@ my $is_windows = $^O eq 'MSWin32'; # executable. my $is_absolute_re; my $has_dir_element_re; +my $path_sep; my @extensions = (''); if ($is_windows) { $is_absolute_re = '^(?:(?:[a-zA-Z]:[\\\\/])|(?:[\\\\/]{2}\w+[\\\\/]))'; $has_dir_element_re = "[\\\\/]"; + $path_sep = "\\"; push(@extensions, '.exe'); } else { $is_absolute_re = "^/"; $has_dir_element_re = "/"; + $path_sep = "/"; } # Make this class a subclass of Proc::Win32 or Proc::Unix. Any # unresolved method calls will go to either of these classes. if ($is_windows) { require Proc::Background::Win32; - unshift(@ISA, 'Proc::Background::Win32'); + unshift(@Proc::Background::ISA, 'Proc::Background::Win32'); } else { require Proc::Background::Unix; - unshift(@ISA, 'Proc::Background::Unix'); + unshift(@Proc::Background::ISA, 'Proc::Background::Unix'); } # Take either a relative or absolute path to a command and make it an @@ -50,7 +49,7 @@ if ($is_windows) { sub _resolve_path { my $command = shift; - return unless length $command; + return ( undef, 'empty command string' ) unless length $command; # Make the path to the progam absolute if it isn't already. If the # path is not absolute and if the path contains a directory element @@ -67,13 +66,11 @@ sub _resolve_path { last; } } - unless (defined $path) { - warn "$0: no executable program located at $command\n"; - } + return defined $path? ( $path, undef ) : ( undef, "no executable program located at $command" ); } else { my $cwd = cwd; if ($command =~ /$has_dir_element_re/o) { - my $p1 = "$cwd/$command"; + my $p1 = "$cwd$path_sep$command"; foreach my $ext (@extensions) { my $p2 = "$p1$ext"; if (-f $p2 and -x _) { @@ -84,8 +81,8 @@ sub _resolve_path { } else { foreach my $dir (split($is_windows ? ';' : ':', $ENV{PATH})) { next unless length $dir; - $dir = "$cwd/$dir" unless $dir =~ /$is_absolute_re/o; - my $p1 = "$dir/$command"; + $dir = "$cwd$path_sep$dir" unless $dir =~ /$is_absolute_re/o; + my $p1 = "$dir$path_sep$command"; foreach my $ext (@extensions) { my $p2 = "$p1$ext"; if (-f $p2 and -x _) { @@ -96,12 +93,20 @@ sub _resolve_path { last if defined $path; } } - unless (defined $path) { - warn "$0: cannot find absolute location of $command\n"; - } + return defined $path? ( $path, undef ) : ( undef, "cannot find absolute location of $command" ); } +} - $path; +# Define the set of allowed options, to warn about unknown ones. +# Make it a method so subclasses can override it. +%Proc::Background::_available_options= ( + autodie => 1, command => 1, exe => 1, + cwd => 1, stdin => 1, stdout => 1, stderr => 1, + autoterminate => 1, die_upon_destroy => 1, +); + +sub _available_options { + return \%Proc::Background::_available_options; } # We want the created object to live in Proc::Background instead of @@ -109,46 +114,123 @@ sub _resolve_path { sub new { my $class = shift; + # The parameters are an optional %options hashref followed by any number + # of arguments to become the @argv for exec(). If options are given, check + # the keys for typos. my $options; - if (@_ and defined $_[0] and UNIVERSAL::isa($_[0], 'HASH')) { - $options = shift; + if (@_ and ref $_[0] eq 'HASH') { + $options= shift; + my $known= $class->_available_options; + my @unknown= grep !$known->{$_}, keys %$options; + carp "Unknown options: ".join(', ', @unknown) + if @unknown; + } + else { + $options= {}; } - unless (@_ > 0) { - confess "Proc::Background::new called with insufficient number of arguments"; + my $self= bless {}, $class; + $self->{_autodie}= 1 if $options->{autodie}; + + # Resolve any confusion between the 'command' option and positional @argv params. + # Store the command in $self->{_command} so that the ::Unix and ::Win32 don't have + # to deal with it redundantly. + my $cmd= $options->{command}; + if (defined $cmd) { + croak "Can't use both 'command' option and command argument list" + if @_; + # Can be an arrayref or a single string + croak "command must be a non-empty string or an arrayref of strings" + unless (ref $cmd eq 'ARRAY' && defined $cmd->[0] && length $cmd->[0]) + or (!ref $cmd && defined $cmd && length $cmd); + } + else { + # Back-compat: maintain original API quirks + confess "Proc::Background::new called with insufficient number of arguments" + unless @_; + return $self->_fatal('command is undefined') unless defined $_[0]; + + # Interpret the parameters as an @argv if there is more than one, + # or if the 'exe' option was given. + $cmd= (@_ > 1 || defined $options->{exe})? [ @_ ] : $_[0]; } - return unless defined $_[0]; + $self->{_command}= $cmd; + $self->{_exe}= $options->{exe} if defined $options->{exe}; - my $self = $class->SUPER::_new(@_) or return; + # Also back-compat: failing to fork or CreateProcess returns undef + return unless $self->_start($options); - # Save the start time of the class. + # Save the start time $self->{_start_time} = time; - # Handle the specific options. - if ($options) { - $self->{_die_upon_destroy} = $options->{die_upon_destroy}; + if ($options->{autoterminate} || $options->{die_upon_destroy}) { + $self->autoterminate(1); } - bless $self, $class; + return $self; +} + +# The original API returns undef from the constructor in case of various errors. +# The autodie option converts these undefs into exceptions. +sub _fatal { + my ($self, $message)= @_; + croak $message if $self->{_autodie}; + warn "$0: $message"; + return undef; +} + +sub autoterminate { + my ($self, $newval)= @_; + if (@_ > 1 and ($newval xor $self->{_die_upon_destroy})) { + if ($newval) { + # Global destruction can break this feature, because there are no guarantees + # on which order object destructors are called. In order to avoid that, need + # to run all the ->die methods during END{}, and that requires weak + # references which weren't available until 5.8 + $weaken_subref->( $Proc::Background::_die_upon_destroy{$self+0}= $self ) + if $weaken_subref; + # could warn about it for earlier perl... but has been broken for 15 years and + # who is still using < 5.8 anyway? + } + else { + delete $Proc::Background::_die_upon_destroy{$self+0}; + } + $self->{_die_upon_destroy}= $newval? 1 : 0; + } + $self->{_die_upon_destroy} || 0 } sub DESTROY { my $self = shift; if ($self->{_die_upon_destroy}) { - $self->die; + # During a mainline exit() $? is the prospective exit code from the + # parent program. Preserve it across any waitpid() in die() + local $?; + $self->terminate; + delete $Proc::Background::_die_upon_destroy{$self+0}; + } +} + +END { + # Child processes need killed before global destruction, else the + # Win32::Process objects might get destroyed first. + for (grep defined, values %Proc::Background::_die_upon_destroy) { + $_->terminate; + delete $_->{_die_upon_destroy} } + %Proc::Background::_die_upon_destroy= (); } -# Reap the child. If the first argument is 0 the wait should return -# immediately, 1 if it should wait forever. If this number is -# non-zero, then wait. If the wait was sucessful, then delete +# Reap the child. If the first argument is false, then return immediately. +# Else, block waiting for the process to exit. If no second argument is +# given, wait forever, else wait for that number of seconds. +# If the wait was sucessful, then delete # $self->{_os_obj} and set $self->{_exit_value} to the OS specific # class return of _reap. Return 1 if we sucessfully waited, 0 # otherwise. sub _reap { - my $self = shift; - my $timeout = shift || 0; + my ($self, $blocking, $wait_seconds) = @_; return 0 unless exists($self->{_os_obj}); @@ -156,9 +238,9 @@ sub _reap { # the Proc::Background::*::waitpid call, which returns one of three # values. # (0, exit_value) : sucessfully waited on. - # (1, undef) : process already reaped and exist value lost. + # (1, undef) : process already reaped and exit value lost. # (2, undef) : process still running. - my ($result, $exit_value) = $self->_waitpid($timeout); + my ($result, $exit_value) = $self->_waitpid($blocking, $wait_seconds); if ($result == 0 or $result == 1) { $self->{_exit_value} = defined($exit_value) ? $exit_value : 0; delete $self->{_os_obj}; @@ -183,39 +265,79 @@ sub alive { !$self->_reap(0); } -sub wait { - my $self = shift; +sub suspended { + $_[0]->{_suspended}? 1 : 0 +} - # If neither _os_obj or _exit_value are set, then something is wrong. - if (!exists($self->{_exit_value}) and !exists($self->{_os_obj})) { - return; - } +sub suspend { + my $self= shift; + return $self->_fatal("can't suspend, process has exited") + if !$self->{_os_obj}; + $self->{_suspended} = 1 if $self->_suspend; + return $self->{_suspended}; +} + +sub resume { + my $self= shift; + return $self->_fatal("can't resume, process has exited") + if !$self->{_os_obj}; + $self->{_suspended} = 0 if $self->_resume; + return !$self->{_suspended}; +} + +sub wait { + my ($self, $timeout_seconds) = @_; # If $self->{_exit_value} exists, then we already waited. return $self->{_exit_value} if exists($self->{_exit_value}); - # Otherwise, wait forever for the process to finish. - $self->_reap(1); - return $self->{_exit_value}; + carp "calling ->wait on a suspended process" if $self->{_suspended}; + + # If neither _os_obj or _exit_value are set, then something is wrong. + return undef if !exists($self->{_os_obj}); + + # Otherwise, wait for the process to finish. + return $self->_reap(1, $timeout_seconds)? $self->{_exit_value} : undef; } +sub terminate { shift->die(@_) } sub die { my $self = shift; + croak "process is already terminated" if $self->{_autodie} && !$self->{_os_obj}; + # See if the process has already died. return 1 unless $self->alive; # Kill the process using the OS specific method. - $self->_die; + $self->_terminate(@_? ([ @_ ]) : ()); # See if the process is still alive. !$self->alive; } +sub command { + $_[0]->{_command}; +} + +sub exe { + $_[0]->{_exe} +} + sub start_time { $_[0]->{_start_time}; } +sub exit_code { + return undef unless exists $_[0]->{_exit_value}; + return $_[0]->{_exit_value} >> 8; +} + +sub exit_signal { + return undef unless exists $_[0]->{_exit_value}; + return $_[0]->{_exit_value} & 127; +} + sub end_time { $_[0]->{_end_time}; } @@ -236,14 +358,22 @@ sub timeout_system { my $proc = Proc::Background->new(@_) or return; my $end_time = $proc->start_time + $timeout; - while ($proc->alive and time < $end_time) { - sleep(1); + my $delay= $timeout; + while ($delay > 0 && defined $proc->{_os_obj}) { + last if defined $proc->wait($delay); + # If it times out, it's likely that wait() already waited the entire duration. + # But, if it got interrupted, there might be time remaining. + # But, if the system clock changes, this could break horribly. Constrain it to a sane value. + my $t= time; + if ($t < $end_time - $delay) { # time moved backward! + $end_time= $t + $delay; + } else { + $delay= $end_time - $t; + } } my $alive = $proc->alive; - if ($alive) { - $proc->die; - } + $proc->terminate if $alive; if (wantarray) { return ($proc->wait, $alive); @@ -258,29 +388,38 @@ __END__ =pod -=head1 NAME - -Proc::Background - Generic interface to Unix and Win32 background process management - =head1 SYNOPSIS - use Proc::Background; - timeout_system($seconds, $command, $arg1); - timeout_system($seconds, "$command $arg1"); - - my $proc1 = Proc::Background->new($command, $arg1, $arg2); - my $proc2 = Proc::Background->new("$command $arg1 1>&2"); - $proc1->alive; - $proc1->die; + use Proc::Background 'timeout_system'; + timeout_system($seconds, $command, $arg1, $arg2); + timeout_system($seconds, "$command $arg1 $arg2"); + + my $proc1 = Proc::Background->new($command, $arg1, $arg2) || die "failed"; + my $proc2 = Proc::Background->new("$command $arg1 1>&2") || die "failed"; + if ($proc1->alive) { + $proc1->terminate; $proc1->wait; - my $time1 = $proc1->start_time; - my $time2 = $proc1->end_time; - - # Add an option to kill the process with die when the variable is - # DETROYed. - my $opts = {'die_upon_destroy' => 1}; - my $proc3 = Proc::Background->new($opts, $command, $arg1, $arg2); - $proc3 = undef; + } + say 'Ran for ' . ($proc1->end_time - $proc1->start_time) . ' seconds'; + + Proc::Background->new({ + autodie => 1, # Throw exceptions instead of returning undef + cwd => 'some/path/', # Set working directory for the new process + exe => 'busybox', # Specify executable different from argv[0] + command => [ $command ] # resolve ambiguity of command line vs. argv[0] + }); + + # Set initial file handles + Proc::Background->new({ + stdin => undef, # /dev/null or NUL + stdout => '/append/to/fname', # will try to open() + stderr => $log_fh, # use existing handle + command => \@command, + }); + + # Automatically kill the process if the object gets destroyed + my $proc4 = Proc::Background->new({ autoterminate => 1 }, $command); + $proc4 = undef; # calls ->terminate =head1 DESCRIPTION @@ -288,7 +427,7 @@ This is a generic interface for placing processes in the background on both Unix and Win32 platforms. This module lets you start, kill, wait on, retrieve exit values, and see if background processes still exist. -=head1 METHODS +=head1 CONSTRUCTOR =over 4 @@ -296,67 +435,114 @@ on, retrieve exit values, and see if background processes still exist. =item B [options] 'I [I [I ...]]' -This creates a new background process. As exec() or system() may be -passed an array with a single single string element containing a -command to be passed to the shell or an array with more than one -element to be run without calling the shell, B has the same -behavior. - -In certain cases B will attempt to find I on the system -and fail if it cannot be found. - -For Win32 operating systems: - - The Win32::Process module is always used to spawn background - processes on the Win32 platform. This module always takes a - single string argument containing the executable's name and - any option arguments. In addition, it requires that the - absolute path to the executable is also passed to it. If - only a single argument is passed to new, then it is split on - whitespace into an array and the first element of the split - array is used at the executable's name. If multiple - arguments are passed to new, then the first element is used - as the executable's name. - - If the executable's name is an absolute path, then new - checks to see if the executable exists in the given location - or fails otherwise. If the executable's name is not - absolute, then the executable is searched for using the PATH - environmental variable. The input executable name is always - replaced with the absolute path determined by this process. - - In addition, when searching for the executable, the - executable is searched for using the unchanged executable - name and if that is not found, then it is checked by - appending `.exe' to the name in case the name was passed - without the `.exe' suffix. - - Finally, the argument array is placed back into a single - string and passed to Win32::Process::Create. - -For non-Win32 operating systems, such as Unix: - - If more than one argument is passed to new, then new - assumes that the command will not be passed through the - shell and the first argument is the executable's relative - or absolute path. If the first argument is an absolute - path, then it is checked to see if it exists and can be - run, otherwise new fails. If the path is not absolute, - then the PATH environmental variable is checked to see if - the executable can be found. If the executable cannot be - found, then new fails. These steps are taking to prevent - exec() from failing after an fork() without the caller of - new knowing that something failed. - -The first argument to B I may be a reference to a hash -which contains key/value pairs to modify Proc::Background's behavior. -Currently the only key understood by B is I. -When this value is set to true, then when the Proc::Background object -is being DESTROY'ed for any reason (i.e. the variable goes out of -scope) the process is killed via the die() method. - -If anything fails, then new returns an empty list in a list context, -an undefined value in a scalar context, or nothing in a void context. +This creates a new background process. Just like C, you can +supply a single string of the entire command line, or individual +arguments. The first argument may be a hashref of named options. +To resolve the ambiguity between a command line vs. a single-element +argument list, see the C option below. + +By default, the constructor returns an empty list on failure, +except for a few cases of invalid arguments which call C. + +For platform-specific details, see L +or L, but in short: + +=over 7 + +=item Unix + +This implementation uses C/C. If you supply a single-string +command line, it is passed to the shell. If you supply multiple arguments, +they are passed to C. In the multi-argument case, it will also check +that the executable exists before calling C. + +=item Win32 + +This implementation uses the L. +If you supply a single-string command line, it derives the executable by +parsing the command line and looking for the first element in the C, +appending C<".exe"> if needed. If you supply multiple arguments, the +first is used as the C and the command line is built using +L. To let Windows search for the executable, pass option +C<< { exe => undef } >>. + +=back + +B + +=over + +=item C + +This module traditionally has returned C if the child could not +be started. Modern Perl recommends the use of exceptions for things +like this. This option, like Perl's L pragma, causes all +fatal errors in starting the process to die with exceptions instead of +returning undef. (module-usage errors or other problems prior to +launching the process may still 'croak' regardless of this setting) + +=item C + +You may specify the command as an option instead of passing the command +as a list. A string value is considered a command line, and an arrayref +value is considered an argument list. Using this option resolves the +ambiguity in the plain-list constructor between a command line vs. +a single-element argument list. + +=item C + +Specify the executable. This can serve two purposes: +on Win32 it avoids the need to parse the commandline, and on Unix it can be +used to run an executable while passing a different value for C<$ARGV[0]>. + +=item C, C, C + +Specify one or more overrides for the standard handles of the child. +The value should be a Perl filehandle with an underlying system C +value. As a convenience, you can pass C to open the C device +on Win32 or C on Unix. You may also pass a plain-scalar file +name which this module will attmept to open for reading or appending. + +(for anything more elaborate, see L instead) + +Note that on Win32, none of the parent's handles are inherited by default, +which is the opposite on Unix. When you specify any of these handles on +Win32 the default will change to inherit the rest from the parent. + +=item C + +Specify a path which should become the child process's current working +directory. The path must already exist. + +=item C + +If you pass a true value for this option, then destruction of the +Proc::Background object (going out of scope, or script-end) will kill the +process via C<< ->terminate >>. Without this option, the child process +continues running. C is an alias for this option, used +by previous versions of this module. + +=back + +=back + +=head1 ATTRIBUTES + +=over + +=item B + +The command (string or arrayref) that was passed to the constructor. + +=item B + +The path to the executable that was passed as an option to the constructor, +or derived from the C. + +=item B + +Return the value that the Perl function time() returned when the +process was started. =item B @@ -365,36 +551,103 @@ even if the process has already finished. =item B -Return 1 if the process is still active, 0 otherwise. +Return 1 if the process is still active, 0 otherwise. This makes a +non-blocking call to C to check the real status of the process if it +has not been reaped yet. -=item B +=item B -Reliably try to kill the process. Returns 1 if the process no longer -exists once B has completed, 0 otherwise. This will also return -1 if the process has already died. On Unix, the following signals are -sent to the process in one second intervals until the process dies: -HUP, QUIT, INT, KILL. +Boolean whether the process is thought to be stopped. This does not actually +consult the operating system, and just returns the last known status from a +call to C or C. It is always false if C is false. + +=item B + +Returns the exit code of the process, assuming it exited cleanly. +Returns C if the process has not exited yet, and 0 if the +process exited with a signal (or TerminateProcess). Since 0 is +ambiguous, check for C first. + +=item B + +Returns the value of the signal the process exited with, assuming it +died on a signal. Returns C if it has not exited yet, and 0 +if it did not die to a signal. + +=item B + +Return the value that the Perl function time() returned when the exit +status was obtained from the process. + +=item B + +This writeable attribute lets you enable or disable the autoterminate +option, which could also be passed to the constructor. + +=back + +=head1 METHODS + +=over =item B + $exit= $proc->wait; # blocks forever + $exit= $proc->wait($timeout_seconds); # since version 1.20 + Wait for the process to exit. Return the exit status of the command as returned by wait() on the system. To get the actual exit value, divide by 256 or right bit shift by 8, regardless of the operating -system being used. If the process never existed, then return an empty -list in a list context, an undefined value in a scalar context, or -nothing in a void context. This function may be called multiple times -even after the process has exited and it will return the same exit -status. +system being used. If the process never existed, this returns undef. +This function may be called multiple times even after the process has +exited and it will return the same exit status. -=item B +Since version 1.20, you may pass an optional argument of the number of +seconds to wait for the process to exit. This may be fractional, and +if it is zero then the wait will be non-blocking. Note that on Unix +this is implemented with L before a call to wait(), +so it may not be compatible with scripts that use alarm() for other +purposes, or systems/perls that resume system calls after a signal. +In the event of a timeout, the return will be undef. -Return the value that the Perl function time() returned when the -process was started. +=item B -=item B +Pause the process. This returns true if the process is stopped afterward. +This throws an excetion if the process is not C and C is +enabled. -Return the value that the Perl function time() returned when the exit -status was obtained from the process. +=item B + +Resume a paused process. This returns true if the process is not stopped +afterward. This throws an exception if the process is not C and +C is enabled. + +=item B, B + +Reliably try to kill the process. Returns 1 if the process no longer +exists once B has completed, 0 otherwise. This will also return +1 if the process has already exited. + +C<@kill_sequence> is a list of actions and seconds-to-wait for that +action to end the process. The default is C< TERM 2 TERM 8 KILL 3 KILL 7 >. +On Unix this sends SIGTERM and SIGKILL; on Windows it just calls +TerminateProcess (graceful termination is still a TODO). + +Note that C (formerly named C) on Proc::Background 1.10 +and earlier on Unix called a sequence of: + + ->die( ( HUP => 1 )x5, ( QUIT => 1 )x5, ( INT => 1 )x5, ( KILL => 1 )x5 ); + +which wasn't what most people need, since SIGHUP is open to interpretation, +and QUIT is almost always immediately fatal and generates a coredump. +The new default should accomodate programs that acknowledge a second +SIGTERM, and give enough time for it to exit on a laggy system while still +not holding up the main script too much. + +C is preserved as an alias for C. + +This throws an exception if the process has been reaped and C is +enabled. =back @@ -407,12 +660,7 @@ status was obtained from the process. =item B 'I I [I [I...]]' Run a command for I seconds and if the process did not exit, -then kill it. While the timeout is implemented using sleep(), this -function makes sure that the full I is reached before killing -the process. B does not wait for the complete -I number of seconds before checking if the process has -exited. Rather, it sleeps repeatidly for 1 second and checks to see -if the process still exists. +then kill it. In a scalar context, B returns the exit status from the process. In an array context, B returns a two @@ -430,48 +678,63 @@ scalar context, or nothing in a void context. =back -=head1 IMPLEMENTATION - -I comes with two modules, I -and I. Currently, on Unix platforms -I uses the I class and on -Win32 platforms it uses I, which makes use of -I. - -The I assigns to @ISA either -I or I, which does -the OS dependent work. The OS independent work is done in -I. - -Proc::Background uses two variables to keep track of the process. -$self->{_os_obj} contains the operating system object to reference the -process. On a Unix systems this is the process id (pid). On Win32, -it is an object returned from the I class. When -$self->{_os_obj} exists, then the process is running. When the -process dies, this is recorded by deleting $self->{_os_obj} and saving -the exit value $self->{_exit_value}. - -Anytime I is called, a waitpid() is called on the process and -the return status, if any, is gathered and saved for a call to -I. This module does not install a signal handler for SIGCHLD. -If for some reason, the user has installed a signal handler for -SIGCHLD, then, then when this module calls waitpid(), the failure will -be noticed and taken as the exited child, but it won't be able to -gather the exit status. In this case, the exit status will be set to -0. +=head1 BUGS + +The following behaviors aren't ideal, but are preserved for backward-compatibility. + +=over + +=item Commandline vs. Single Argv[] + +C<< ->new($x) >> is treated as a command line. In C<< ->new({ exe => $y }, $x) >>, +$x is treated as C<$ARGV[0]>. Use C<< ->new({ command => ... }) >> +(scalar vs. arrayref) to dis-ambiguate. + +=item Win32 Argv Quoting + +This is a bug in Windows, not this module. It is not possible to universally +convert an @ARGV into a commandline, because each Win32 program performs its +own command line parsing, and cmd.exe and find.exe deviate from the majority +of other executables. Those things could be improved with hieuristics, which +this module doesn't have. + +=item Win32 exe determination + +If you don't specify an absolute path for option C, this module manually +searches the %PATH% looking for the executable, and is less thorough than the +native Windows shell behavior. Use C<< { exe => undef } >> to get the naive +Windows exe search. (but you need Win32::Process version 0.17 or newer) + +=item Win32 SIGTERM + +This module only supports TerminateProcess, which is equivalent to SIGKILL, not +SIGTERM. SIGTERM could be emulated by calling taskkill.exe, or using windows +messages. Patches welcome. + +=back =head1 SEE ALSO -See also L and L. +=over + +=item L -=head1 AUTHOR +IPC::Run is a much more complete solution for running child processes. +It handles dozens of forms of redirection and pipe pumping, and should +probably be your first stop for any complex needs. -Blair Zajac +However, also note the very large and slightly alarming list of +limitations it lists for Win32. Proc::Background is a much simpler design +and should be more reliable for simple needs. -=head1 COPYRIGHT +=item L -Copyright (C) 1998-2002 Blair Zajac. All rights reserved. This -package is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. +If you are running on Win32, this article by Daniel Colascione helps +describe the problem you are up against for passing argument lists: +L -=cut +This module gives you parsing / quoting per the standard +CommandLineToArgvW behavior. But, if you need to pass arguments to be +processed by C then you need to do additional work. + +=back diff --git a/CPAN/Proc/Background/Unix.pm b/CPAN/Proc/Background/Unix.pm index a0f8567f541..344e5f0ffb8 100644 --- a/CPAN/Proc/Background/Unix.pm +++ b/CPAN/Proc/Background/Unix.pm @@ -1,78 +1,185 @@ -# Proc::Background::Unix: Unix interface to background process management. -# -# Copyright (C) 1998-2002 Blair Zajac. All rights reserved. - package Proc::Background::Unix; +# ABSTRACT: Unix-specific implementation of process create/wait/kill require 5.004_04; use strict; use Exporter; use Carp; -use POSIX qw(:errno_h :sys_wait_h); +use POSIX qw( :errno_h :sys_wait_h ); + +# Test for existence of FD_CLOEXEC, needed for child-error-through-pipe trick +my ($FD_CLOEXEC); +eval { + require Fcntl; + $FD_CLOEXEC= Fcntl::FD_CLOEXEC(); +}; -use vars qw(@ISA $VERSION); -@ISA = qw(Exporter); -$VERSION = sprintf '%d.%02d', '$Revision: 1.08 $' =~ /(\d+)\.(\d+)/; +# For un-explained mysterious reasons, Time::HiRes::alarm seem to misbehave on 5.10 and earlier +# but core alarm works fine. +my $alarm= ($] >= 5.012)? do { require Time::HiRes; \&Time::HiRes::alarm; } + : sub { + # round up to whole seconds + CORE::alarm(POSIX::ceil($_[0])); + }; + +@Proc::Background::Unix::ISA = qw(Exporter); # Start the background process. If it is started sucessfully, then record # the process id in $self->{_os_obj}. -sub _new { - my $class = shift; +sub _start { + my ($self, $options)= @_; + + # There are three main scenarios for how-to-exec: + # * single-string command, to be handled by shell + # * arrayref command, to be handled by execve + # * arrayref command with 'exe' (fake argv0) + # and one that isn't logical: + # * single-string command with exe + # throw an error for that last one rather than trying something awkward + # like splitting the command string. - unless (@_ > 0) { - confess "Proc::Background::Unix::_new called with insufficient number of arguments"; + my @argv; + my ($cmd, $exe)= @{$self}{'_command','_exe'}; + + if (ref $cmd eq 'ARRAY') { + @argv= @$cmd; + ($exe, my $err) = Proc::Background::_resolve_path(defined $exe? $exe : $argv[0]); + return $self->_fatal($err) unless defined $exe; + $self->{_exe}= $exe; + } elsif (defined $exe) { + croak "Can't combine 'exe' option with single-string 'command', use arrayref 'command' instead."; } - return unless defined $_[0]; - - # If there is only one element in the @_ array, then it may be a - # command to be passed to the shell and should not be checked, in - # case the command sets environmental variables in the beginning, - # i.e. 'VAR=arg ls -l'. If there is more than one element in the - # array, then check that the first element is a valid executable - # that can be found through the PATH and find the absolute path to - # the executable. If the executable is found, then replace the - # first element it with the absolute path. - my @args = @_; - if (@_ > 1) { - $args[0] = Proc::Background::_resolve_path($args[0]) or return; + if (defined $options->{cwd}) { + -d $options->{cwd} + or return $self->_fatal("directory does not exist: '$options->{cwd}'"); } - my $self = bless {}, $class; + my ($new_stdin, $new_stdout, $new_stderr); + $new_stdin= _resolve_file_handle($options->{stdin}, '<', \*STDIN) + if exists $options->{stdin}; + $new_stdout= _resolve_file_handle($options->{stdout}, '>>', \*STDOUT) + if exists $options->{stdout}; + $new_stderr= _resolve_file_handle($options->{stderr}, '>>', \*STDERR) + if exists $options->{stderr}; # Fork a child process. + my ($pipe_r, $pipe_w); + if (defined $FD_CLOEXEC) { + # use a pipe for the child to report exec() errors + pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!"); + # This pipe needs to be in the non-preserved range that doesn't exist after exec(). + # In the edge case where a pipe received a FD less than $^F, the CLOEXEC flag isn't set. + # Try again on higher descriptors, then close the lower ones. + my @rejects; + while (fileno $pipe_r <= $^F or fileno $pipe_w <= $^F) { + push @rejects, $pipe_r, $pipe_w; + pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!"); + } + } my $pid; { if ($pid = fork()) { # parent $self->{_os_obj} = $pid; $self->{_pid} = $pid; + if (defined $pipe_r) { + close $pipe_w; + # wait for child to reply or close the pipe + local $SIG{PIPE}= sub {}; + my $msg= ''; + while (0 < read $pipe_r, $msg, 1024, length $msg) {} + close $pipe_r; + # If child wrote anything to the pipe, it failed to exec. + # Reap it before dying. + if (length $msg) { + waitpid $pid, 0; + return $self->_fatal($msg); + } + } last; } elsif (defined $pid) { # child - exec @_ or croak "$0: exec failed: $!\n"; + # Make absolutely sure nothing in this block interacts with the rest of the + # process state, and that flow control never skips the _exit(). + $SIG{$_}= sub{die;} for qw( INT HUP QUIT TERM ); # clear custom signal handlers + $SIG{$_}= 'DEFAULT' for qw( __WARN__ __DIE__ ); + eval { + eval { + chdir($options->{cwd}) or die "chdir($options->{cwd}): $!\n" + if defined $options->{cwd}; + + open STDIN, '<&'.fileno($new_stdin) or die "Can't redirect STDIN: $!\n" + if defined $new_stdin; + open STDOUT, '>&'.fileno($new_stdout) or die "Can't redirect STDOUT: $!\n" + if defined $new_stdout; + open STDERR, '>&'.fileno($new_stderr) or die "Can't redirect STDERR: $!\n" + if defined $new_stderr; + + if (defined $exe) { + exec { $exe } @argv or die "$0: exec failed: $!\n"; + } else { + exec $cmd or die "$0: exec failed: $!\n"; + } + }; + if (defined $pipe_w) { + print $pipe_w $@; + close $pipe_w; # force it to flush. Nothing else needs closed because we are about to _exit + } else { + print STDERR $@; + } + }; + POSIX::_exit(1); } elsif ($! == EAGAIN) { sleep 5; redo; } else { - return; + return $self->_fatal("fork: $!"); } } $self; } +sub _resolve_file_handle { + my ($thing, $mode, $default)= @_; + if (!defined $thing) { + open my $fh, $mode, '/dev/null' or croak "open(/dev/null): $!"; + return $fh; + } elsif (ref $thing) { + # use 'undef' to mean no-change + return (fileno($thing) == fileno($default))? undef : $thing; + } else { + open my $fh, $mode, $thing or croak "open($thing): $!"; + return $fh; + } +} + # Wait for the child. +# (0, exit_value) : sucessfully waited on. +# (1, undef) : process already reaped and exit value lost. +# (2, undef) : process still running. sub _waitpid { - my $self = shift; - my $timeout = shift; + my ($self, $blocking, $wait_seconds) = @_; { # Try to wait on the process. - my $result = waitpid($self->{_os_obj}, $timeout ? 0 : WNOHANG); + # Implement the optional timeout with the 'alarm' call. + my $result= 0; + if ($blocking && $wait_seconds) { + local $SIG{ALRM}= sub { die "alarm\n" }; + $alarm->($wait_seconds); + eval { $result= waitpid($self->{_os_obj}, 0); }; + $alarm->(0); + } + else { + $result= waitpid($self->{_os_obj}, $blocking? 0 : WNOHANG); + } + # Process finished. Grab the exit value. if ($result == $self->{_os_obj}) { + delete $self->{_suspended}; return (0, $?); } # Process already reaped. We don't know the exist status. @@ -89,21 +196,25 @@ sub _waitpid { return 0; } -sub _die { - my $self = shift; +sub _suspend { + kill STOP => $_[0]->{_os_obj}; +} + +sub _resume { + kill CONT => $_[0]->{_os_obj}; +} +sub _terminate { + my $self = shift; + my @kill_sequence= @_ && ref $_[0] eq 'ARRAY'? @{ $_[0] } : qw( TERM 2 TERM 8 KILL 3 KILL 7 ); # Try to kill the process with different signals. Calling alive() will # collect the exit status of the program. - SIGNAL: { - foreach my $signal (qw(HUP QUIT INT KILL)) { - my $count = 5; - while ($count and $self->alive) { - --$count; - kill($signal, $self->{_os_obj}); - last SIGNAL unless $self->alive; - sleep 1; - } - } + while (@kill_sequence and $self->alive) { + my $sig= shift @kill_sequence; + my $delay= shift @kill_sequence; + kill($sig, $self->{_os_obj}); + next unless defined $delay; + last if $self->_reap(1, $delay); # block before sending next signal } } @@ -111,28 +222,42 @@ sub _die { __END__ -=head1 NAME +=head1 DESCRIPTION -Proc::Background::Unix - Unix interface to process mangement +This module does not have a public interface. Use L. -=head1 SYNOPSIS +=head1 IMPLEMENTATION -Do not use this module directly. +=head2 Command vs. Exec -=head1 DESCRIPTION +Unix systems start a new process by creating a mirror of the current process +(C) and then having it alter its own state to prepare for the new +program, and then calling C to replace the running code with code loaded +from a new file. However, there is a second common method where the user +wants to specify a command line string as they would type it in their shell. +In this case, the actual program being executed is the shell, and the command +line is given as one element of its argument list. -This is a process management class designed specifically for Unix -operating systems. It is not meant used except through the -I class. See L for more information. +Perl already supports both methods, such that if you pass one string to C +containing shell characters, it calls the shell, and if you pass multiple +arguments, it directly invokes C. -=head1 AUTHOR +This module mostly just lets Perl's C do its job, but also checks for +the existence of the executable first, to make errors easier to catch. This +check is skipped if there is a single-string command line. -Blair Zajac +Unix lets you run a different executable than what is listed in the first +argument. (this feature lets one Unix executable behave as multiple +different programs depending on what name it sees in the first argument) +You can use that feature by passing separate options of C and C +to this module's constructor instead of a simple argument list. But, you +can't mix a C option with a shell-interpreted command line string. -=head1 COPYRIGHT +=head2 Errors during Exec -Copyright (C) 1998-2002 Blair Zajac. All rights reserved. This -package is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. +If the C option is enabled, and the system supports C, +this module uses a trick where the forked child relays any errors through +a pipe so that the parent can throw and handle the exception directly instead +of creating a child process that is dead-on-arrival with the error on STDERR. =cut diff --git a/CPAN/Proc/Background/Win32.pm b/CPAN/Proc/Background/Win32.pm index 8aa2347df9b..320a34e622e 100644 --- a/CPAN/Proc/Background/Win32.pm +++ b/CPAN/Proc/Background/Win32.pm @@ -1,104 +1,152 @@ -# Proc::Background::Win32 Windows interface to background process management. -# -# Copyright (C) 1998-2002 Blair Zajac. All rights reserved. - package Proc::Background::Win32; +# ABSTRACT: Windows-specific implementation of process create/wait/kill require 5.004_04; use strict; use Exporter; use Carp; +use Win32; +use Win32::Process qw( NORMAL_PRIORITY_CLASS INFINITE ); +use Win32::ShellQuote (); + +@Proc::Background::Win32::ISA = qw(Exporter); + +sub _start { + my ($self, $options)= @_; + my ($cmd, $exe, $cmdline, $err)= @{$self}{'_command','_exe'}; + + # If 'command' is a single string, treat it as system() would and assume + # it should be split into arguments. The first argument is then the + # application executable, if not already specified as an option. + if (ref $cmd ne 'ARRAY') { + $cmdline= $cmd; + ($exe) = Win32::ShellQuote::unquote_native($cmdline) + unless exists $options->{exe}; + } + # system() would treat a list of arguments as an un-quoted ARGV + # for the program, so concatenate them into a command line appropriate + # for Win32 CommandLineToArgvW to decode back to what we started with. + # Preserve the first un-quoted argument for use as lpApplicationName, + # unless user requested some value (including undef). + else { + $exe = $cmd->[0] unless exists $options->{exe}; + $cmdline= Win32::ShellQuote::quote_native(@$cmd); + } -use vars qw(@ISA $VERSION); -@ISA = qw(Exporter); -$VERSION = sprintf '%d.%02d', '$Revision: 1.08 $' =~ /(\d+)\.(\d+)/; - -BEGIN { - eval "use Win32"; - $@ and die "Proc::Background::Win32 needs Win32 from libwin32-?.??.zip to run.\n"; - eval "use Win32::Process"; - $@ and die "Proc::Background::Win32 needs Win32::Process from libwin32-?.??.zip to run.\n"; -} - -sub _new { - my $class = shift; + if (defined $exe) { + # Find the absolute path to the program. If it cannot be found, + # then return. + ($exe, $err) = Proc::Background::_resolve_path($exe); + return $self->_fatal($err) unless defined $exe; + # To work around a problem where Win32::Process::Create cannot start a + # process when the full pathname has a space in it, convert the full + # pathname to the Windows short 8.3 format which contains no spaces. + $exe = Win32::GetShortPathName($exe) + } + else { + Win32::Process->VERSION > 0.16 + or croak "{exe => undef} feature requires Win32::Process 0.17"; + } - unless (@_ > 0) { - confess "Proc::Background::Win32::_new called with insufficient number of arguments"; + my $cwd= '.'; + if (defined $options->{cwd}) { + -d $options->{cwd} + or return $self->_fatal("directory does not exist: '$options->{cwd}'"); + $cwd= $options->{cwd}; } - return unless defined $_[0]; - - # If there is only one element in the @_ array, then just split the - # argument by whitespace. If there is more than one element in @_, - # then assume that each argument should be properly protected from - # the shell so that whitespace and special characters are passed - # properly to the program, just as it would be in a Unix - # environment. This will ensure that a single argument with - # whitespace will not be split into multiple arguments by the time - # the program is run. Make sure that any arguments that are already - # protected stay protected. Then convert unquoted "'s into \"'s. - # Finally, check for whitespace and protect it. - my @args; - if (@_ == 1) { - @args = split(' ', $_[0]); + # On Strawberry Perl, CreateProcess will inherit the current process STDIN/STDOUT/STDERR, + # but there is no way to specify them without altering the current process. + # So, redirect handles, then create process, then revert them. + my ($inherit, $new_stdin, $old_stdin, $new_stdout, $old_stdout, $new_stderr, $old_stderr); + if (exists $options->{stdin}) { + $inherit= 1; + $new_stdin= _resolve_file_handle($options->{stdin}, '<', \*STDIN); + open $old_stdin, '<&'.fileno(\*STDIN) or croak "Can't save STDIN: $!\n" + if defined $new_stdin; + } + if (exists $options->{stdout}) { + $inherit= 1; + $new_stdout= _resolve_file_handle($options->{stdout}, '>>', \*STDOUT); + open $old_stdout, '>&'.fileno(\*STDOUT) or croak "Can't save STDOUT: $!\n" + if defined $new_stdout; + } + if (exists $options->{stderr}) { + $inherit= 1; + $new_stderr= _resolve_file_handle($options->{stderr}, '>>', \*STDERR); + open $old_stderr, '>&'.fileno(\*STDERR) or croak "Can't save STDERR: $!\n" + if defined $new_stderr; + } + + { + local $@; + eval { + open STDIN, '<&'.fileno($new_stdin) or die "Can't redirect STDIN: $!\n" + if defined $new_stdin; + open STDOUT, '>&'.fileno($new_stdout) or die "Can't redirect STDOUT: $!\n" + if defined $new_stdout; + open STDERR, '>&'.fileno($new_stderr) or die "Can't redirect STDERR: $!\n" + if defined $new_stderr; + + # Perl 5.004_04 cannot run Win32::Process::Create on a nonexistant + # hash key. + my $os_obj = 0; + + # Create the process. + Win32::Process::Create($os_obj, $exe, $cmdline, $inherit, NORMAL_PRIORITY_CLASS, $cwd) + or die Win32::FormatMessage( Win32::GetLastError() )."\n"; + $self->{_pid} = $os_obj->GetProcessID; + $self->{_os_obj} = $os_obj; + }; + chomp($err= $@); + # Now restore handles before throwing exception + open STDERR, '>&'.fileno($old_stderr) or warn "Can't restore STDERR: $!\n" + if defined $old_stderr; + open STDOUT, '>&'.fileno($old_stdout) or warn "Can't restore STDOUT: $!\n" + if defined $old_stdout; + open STDIN, '<&'.fileno($old_stdin) or warn "Can't restore STDIN: $!\n" + if defined $old_stdin; + } + if ($self->{_os_obj}) { + return 1; } else { - @args = @_; - for (my $i=1; $i<@args; ++$i) { - my $arg = $args[$i]; - $arg =~ s#\\\\#\200#g; - $arg =~ s#\\"#\201#g; - $arg =~ s#"#\\"#g; - $arg =~ s#\200#\\\\#g; - $arg =~ s#\201#\\"#g; - if (length($arg) == 0 or $arg =~ /\s/) { - $arg = "\"$arg\""; - } - $args[$i] = $arg; - } + return $self->_fatal($err); } +} - # Find the absolute path to the program. If it cannot be found, - # then return. To work around a problem where - # Win32::Process::Create cannot start a process when the full - # pathname has a space in it, convert the full pathname to the - # Windows short 8.3 format which contains no spaces. - $args[0] = Proc::Background::_resolve_path($args[0]) or return; - $args[0] = Win32::GetShortPathName($args[0]); - - my $self = bless {}, $class; - - # Perl 5.004_04 cannot run Win32::Process::Create on a nonexistant - # hash key. - my $os_obj = 0; - - # Create the process. - if (Win32::Process::Create($os_obj, - $args[0], - "@args", - 0, - CREATE_NO_WINDOW | NORMAL_PRIORITY_CLASS, - '.')) { - $self->{_pid} = $os_obj->GetProcessID; - $self->{_os_obj} = $os_obj; - return $self; +sub _resolve_file_handle { + my ($thing, $mode, $default)= @_; + if (!defined $thing) { + open my $fh, $mode, 'NUL' or croak "open(NUL): $!"; + return $fh; + } elsif (ref $thing) { + return fileno($thing) == fileno($default)? undef : $thing; } else { - return; + open my $fh, $mode, $thing or croak "open($thing): $!"; + return $fh; } } # Reap the child. +# (0, exit_value) : sucessfully waited on. +# (1, undef) : process already reaped and exit value lost. +# (2, undef) : process still running. sub _waitpid { - my ($self, $timeout) = @_; + my ($self, $blocking, $wait_seconds) = @_; # Try to wait on the process. - my $result = $self->{_os_obj}->Wait($timeout ? INFINITE : 0); + my $result = $self->{_os_obj}->Wait($wait_seconds? int($wait_seconds * 1000) : $blocking ? INFINITE : 0); # Process finished. Grab the exit value. if ($result == 1) { - my $_exit_status; - $self->{_os_obj}->GetExitCode($_exit_status); - return (0, $_exit_status<<8); + delete $self->{_suspended}; + my $exit_code; + $self->{_os_obj}->GetExitCode($exit_code); + if ($exit_code == 256 && $self->{_called_terminateprocess}) { + return (0, 9); # simulate SIGKILL exit status + } else { + return (0, $exit_code<<8); + } } # Process still running. elsif ($result == 0) { @@ -108,50 +156,120 @@ sub _waitpid { return (0, 1<<8); } -sub _die { - my $self = shift; - - # Try the kill the process several times. Calling alive() will - # collect the exit status of the program. - my $count = 5; - while ($count and $self->alive) { - --$count; - $self->{_os_obj}->Kill(1<<8); - last unless $self->alive; - sleep 1; - } +sub _suspend { + $_[0]->{_os_obj}->Suspend(); } -1; +sub _resume { + $_[0]->{_os_obj}->Resume(); +} -__END__ +sub _terminate { + my $self = shift; + my @kill_sequence= @_ && ref $_[0] eq 'ARRAY'? @{ $_[0] } : qw( TERM 2 TERM 8 KILL 3 KILL 7 ); + + # Try the kill the process several times. + # _reap will collect the exit status of the program. + while (@kill_sequence and $self->alive) { + my $sig= shift @kill_sequence; + my $delay= shift @kill_sequence; + # TODO: fix _taskkill, then re-enable: $sig eq 'KILL'? $self->_terminateprocess : $self->_taskkill; + $self->_terminateprocess; + next unless defined $delay; + last if $self->_reap(1, $delay); # block before sending next signal + } +} -=head1 NAME +# Use taskkill.exe as a sort of graceful SIGTERM substitute. +sub _taskkill { + my $self = shift; + # TODO: This doesn't work reliably. Disabled for now, and continue to be heavy-handed + # using TerminateProcess. The right solution would either be to do more elaborate setup + # to make sure the correct taskkill.exe is used (and available), or to dig much deeper + # into Win32 API to enumerate windows or threads and send WM_QUIT, or whatever other APIs + # processes might be watching on Windows. That should probably be its own module. + my $pid= $self->{_pid}; + my $out= `taskkill.exe /PID $pid`; + # If can't run taskkill, fall back to TerminateProcess + $self->_terminateprocess unless $? == 0; +} -Proc::Background::Win32 - Interface to process mangement on Win32 systems +# Win32 equivalent of SIGKILL is TerminateProcess() +sub _terminateprocess { + my $self = shift; + $self->{_os_obj}->Kill(256); # call TerminateProcess, essentially SIGKILL + $self->{_called_terminateprocess} = 1; +} -=head1 SYNOPSIS +1; -Do not use this module directly. +__END__ =head1 DESCRIPTION -This is a process management class designed specifically for Win32 -operating systems. It is not meant used except through the -I class. See L for more information. +This module does not have a public interface. Use L. =head1 IMPLEMENTATION -This package uses the Win32::Process class to manage the objects. - -=head1 AUTHOR - -Blair Zajac and C are +a broken approximation of their Unix counterparts. Calling C creates a +I instead of a process, and there is no way to exit the thread without +running Perl cleanup code, which could damage the parent in unpredictable +ways, like closing file handles. Calling C will kill both +parent and child (the whole process), and even calling C in the child +still runs global destruction. File handles are shared between parent and +child, so any file handle redirection you perform in the forked child will +affect the parent and vice versa. + +In short, B call C or C on native Win32 Perl. + +=head2 Command Line + +This module implements background processes using L, which +uses the Windows API's concepts of C, C, +C, C, and so on. + +Windows CreateProcess expects an executable name and a command line; breaking +the command line into an argument list is left to each individual application, +most of which use the library function L. This module +uses L to parse and format Windows command lines. + +If you supply a single-string command line, and don't specify the executable +with the C option, this module parses the first argument from the +command line to be the 'exe' option. It then looks for the 'exe' in +C<< $ENV{PATH} >>, and tries again with a suffix of C<< .exe >> if it didn't +find one. If you specify the option as C<< { exe => undef } >>, this module +skips that step and passes NULL to Win32 C, which causes +Windows to parse the first argument and find the executable on its own. +(Letting Windows search for the executable is probably a better idea anyway, +and this might become the default in the future. It only works with +Win32::Process 0.17 or later) + +If you supply an array of arguments as the command, this module combines them +into a command line using C. The first +argument is used as the executable (unless you specified the C<'exe'> option, +like above). + +=head2 Initial File Handles + +When B are specified, the new process does B +of the current process. This differs from the Unix implementation where they are all +inherited by default, but I'm leaving it this way for backward compatibility. +In other words, yes, they ought to be inherited by default, but changing that now +is more likely to break things than fix things. + +If you specify B of C, C, or C, any handle not +specified B as-is. In other words, by indicating you are +interested in passing file handles, the default Unix behavior occurs. +If you wish to redirect a handle to NUL, set the option to C: + + stdin => undef, # stdin will read from NUL device + stdout => $some_fh, # stdout will write to a file handle + stderr => \*STDERR, # stderr will go to the same STDERR of the current process + +You may set a file handle to a pipe, but beware, Windows does not support +non-blocking reads or writes to pipes. =cut diff --git a/CPAN/arch/5.42/Audio/Scan.pm b/CPAN/arch/5.42/Audio/Scan.pm new file mode 100644 index 00000000000..6ab8fe12707 --- /dev/null +++ b/CPAN/arch/5.42/Audio/Scan.pm @@ -0,0 +1,939 @@ +package Audio::Scan; + +use strict; + +our $VERSION = '1.11'; + +require XSLoader; +XSLoader::load('Audio::Scan', $VERSION); + +use constant FILTER_INFO_ONLY => 1; +use constant FILTER_TAGS_ONLY => 2; + +sub scan_info { + my ( $class, $path, $opts ) = @_; + + $opts ||= {}; + $opts->{filter} = FILTER_INFO_ONLY; + + $class->scan( $path, $opts ); +} + +sub scan_tags { + my ( $class, $path, $opts ) = @_; + + $opts ||= {}; + $opts->{filter} = FILTER_TAGS_ONLY; + + $class->scan( $path, $opts ); +} + +sub scan { + my ( $class, $path, $opts ) = @_; + + my ($filter, $md5_size, $md5_offset); + + open my $fh, '<', $path or do { + warn "Could not open $path for reading: $!\n"; + return; + }; + + binmode $fh; + + my ($suffix) = $path =~ /\.(\w+)$/; + + return if !$suffix; + + if ( defined $opts ) { + if ( !ref $opts ) { + # Back-compat to support filter as normal argument + warn "The Audio::Scan::scan() filter passing method is deprecated, please pass a hashref instead.\n"; + $filter = $opts; + } + else { + $filter = $opts->{filter} || FILTER_INFO_ONLY | FILTER_TAGS_ONLY; + $md5_size = $opts->{md5_size}; + $md5_offset = $opts->{md5_offset}; + } + } + + if ( !defined $filter ) { + $filter = FILTER_INFO_ONLY | FILTER_TAGS_ONLY; + } + + my $ret = $class->_scan( $suffix, $fh, $path, $filter, $md5_size || 0, $md5_offset || 0 ); + + close $fh; + + return $ret; +} + +sub scan_fh { + my ( $class, $suffix, $fh, $opts ) = @_; + + my ($filter, $md5_size, $md5_offset); + + binmode $fh; + + if ( defined $opts ) { + if ( !ref $opts ) { + # Back-compat to support filter as normal argument + warn "The Audio::Scan::scan_fh() filter passing method is deprecated, please pass a hashref instead.\n"; + $filter = $opts; + } + else { + $filter = $opts->{filter} || FILTER_INFO_ONLY | FILTER_TAGS_ONLY; + $md5_size = $opts->{md5_size}; + $md5_offset = $opts->{md5_offset}; + } + } + + if ( !defined $filter ) { + $filter = FILTER_INFO_ONLY | FILTER_TAGS_ONLY; + } + + return $class->_scan( $suffix, $fh, '(filehandle)', $filter, $md5_size || 0, $md5_offset || 0 ); +} + +sub find_frame { + my ( $class, $path, $offset ) = @_; + + open my $fh, '<', $path or do { + warn "Could not open $path for reading: $!\n"; + return; + }; + + binmode $fh; + + my ($suffix) = $path =~ /\.(\w+)$/; + + return -1 if !$suffix; + + my $ret = $class->_find_frame( $suffix, $fh, $path, $offset ); + + close $fh; + + return $ret; +} + +sub find_frame_fh { + my ( $class, $suffix, $fh, $offset ) = @_; + + binmode $fh; + + return $class->_find_frame( $suffix, $fh, '(filehandle)', $offset ); +} + +sub find_frame_return_info { + my ( $class, $path, $offset ) = @_; + + open my $fh, '<', $path or do { + warn "Could not open $path for reading: $!\n"; + return; + }; + + binmode $fh; + + my ($suffix) = $path =~ /\.(\w+)$/; + + return if !$suffix; + + my $ret = $class->_find_frame_return_info( $suffix, $fh, $path, $offset ); + + close $fh; + + return $ret; +} + +sub find_frame_fh_return_info { + my ( $class, $suffix, $fh, $offset ) = @_; + + binmode $fh; + + return $class->_find_frame_return_info( $suffix, $fh, '(filehandle)', $offset ); +} + +1; +__END__ + +=head1 NAME + +Audio::Scan - Fast C metadata and tag reader for all common audio file formats + +=head1 SYNOPSIS + + use Audio::Scan; + + my $data = Audio::Scan->scan('/path/to/file.mp3'); + + # Just file info + my $info = Audio::Scan->scan_info('/path/to/file.mp3'); + + # Just tags + my $tags = Audio::Scan->scan_tags('/path/to/file.mp3'); + + # Scan without reading (possibly large) artwork into memory. + # Instead of binary artwork data, the size of the artwork will be returned instead. + { + local $ENV{AUDIO_SCAN_NO_ARTWORK} = 1; + my $data = Audio::Scan->scan('/path/to/file.mp3'); + } + + # Scan a filehandle + open my $fh, '<', 'my.mp3'; + my $data = Audio::Scan->scan_fh( mp3 => $fh ); + close $fh; + + # Scan and compute an audio MD5 checksum + my $data = Audio::Scan->scan( '/path/to/file.mp3', { md5_size => 100 * 1024 } ); + my $md5 = $data->{info}->{audio_md5}; + +=head1 DESCRIPTION + +Audio::Scan is a C-based scanner for audio file metadata and tag information. It currently +supports MP3, MP4, Ogg Vorbis, FLAC, ASF, WAV, AIFF, Musepack, Monkey's Audio, and WavPack. + +See below for specific details about each file format. + +=head1 METHODS + +=head2 scan( $path, [ \%OPTIONS ] ) + +Scans $path for both metadata and tag information. The type of scan performed is +determined by the file's extension. Supported extensions are: + + MP3: mp3, mp2 + MP4: mp4, m4a, m4b, m4p, m4v, m4r, k3g, skm, 3gp, 3g2, mov + AAC (ADTS): aac + Ogg: ogg, oga + FLAC: flc, flac, fla + ASF: wma, wmv, asf + Musepack: mpc, mpp, mp+ + Monkey's Audio: ape, apl + WAV: wav + AIFF: aiff, aif + WavPack: wv + +This method returns a hashref containing two other hashrefs: info and tags. The +contents of the info and tag hashes vary depending on file format, see below for details. + +An optional hashref may be provided with the following values: + + md5_size => $audio_bytes_to_checksum + +An MD5 will be computed of the first N audio bytes. Any tags in the file are automatically +skipped, so this is a useful way of determining if a file's audio content is the same even +if tags may have been changed. The hex MD5 value is returned in the $info->{audio_md5} +key. This option will reduce performance, so choose a small enough size that works for you, +you should probably avoid using more than 64K for example. + +For FLAC files that already contain an MD5 checksum, this value will be used instead +of calculating a new one. + + md5_offset => $offset + +Begin computing the audio_md5 value starting at $offset. If this value is not specified, +$offset defaults to a point in the middle of the file. + +=head2 scan_info( $path, [ \%OPTIONS ] ) + +If you only need file metadata and don't care about tags, you can use this method. + +=head2 scan_tags( $path, [ \%OPTIONS ] ) + +If you only need the tags and don't care about the metadata, use this method. + +=head2 scan_fh( $type => $fh, [ \%OPTIONS ] ) + +Scans a filehandle. $type is the type of file to scan as, i.e. "mp3" or "ogg". +Note that FLAC does not support reading from a filehandle. + +=head2 find_frame( $path, $timestamp_in_ms ) + +Returns the byte offset to the first audio frame starting from the given timestamp +(in milliseconds). + +=over 4 + +=item MP3, Ogg, FLAC, ASF, MP4 + +The byte offset to the data packet containing this timestamp will be returned. For +file formats that don't provide timestamp information such as MP3, the best estimate for +the location of the timestamp will be returned. This will be more accurate if the +file has a Xing header or is CBR for example. + +=item WAV, AIFF, Musepack, Monkey's Audio, WavPack + +Not yet supported by find_frame. + +=back + +=head2 find_frame_return_info( $path, $timestamp_in_ms ) + +The header of an MP4/OggFlac file contains various metadata that refers to the structure of +the audio data, making seeking more difficult to perform. This method will return +the usual $info hash with 2 additional keys: + + seek_offset - The seek offset in bytes + seek_header - A rewritten MP4/OggFlac header that can be prepended to the audio data + found at seek_offset to construct a valid bitstream. Specifically, for MP4 + the following boxes are rewritten: stts, stsc, stsz, stco. For FLAC, the + number of samples and md5 in STREAMINFO are zero'd + +For example, to seek 30 seconds into a file and write out a new MP4 file seeked to +this point: + + my $info = Audio::Scan->find_frame_return_info( $file, 30000 ); + + open my $f, '<', $file; + sysseek $f, $info->{seek_offset}, 1; + + open my $fh, '>', 'seeked.m4a'; + print $fh $info->{seek_header}; + + while ( sysread( $f, my $buf, 65536 ) ) { + print $fh $buf; + } + + close $f; + close $fh; + +=head2 find_frame_fh( $type => $fh, $offset ) + +Same as C, but with a filehandle. + +=head2 find_frame_fh_return_info( $type => $fh, $offset ) + +Same as C, but with a filehandle. + +=head2 has_flac() + +Deprecated. Always returns 1 now that FLAC is always enabled. + +=head2 is_supported( $path ) + +Returns 1 if the given path can be scanned by Audio::Scan, or 0 if not. + +=head2 get_types() + +Returns an array of strings of the file types supported by Audio::Scan. + +=head2 extensions_for( $type ) + +Returns an array of strings of the file extensions that are considered to +be the file type I<$type>. + +=head2 type_for( $extension ) + +Returns file type for a given extension. Returns I for unsupported +extensions. + +=head1 SKIPPING ARTWORK + +To save memory while reading tags, you can opt to skip potentially large +embedded artwork. To do this, set the environment variable AUDIO_SCAN_NO_ARTWORK: + + local $ENV{AUDIO_SCAN_NO_ARTWORK} = 1; + my $tags = Audio::Scan->scan_tags($file); + +This will return the length of the embedded artwork instead of the actual image data. +In some cases it will also return a byte offset to the image data, which can be used +to extract the image using more efficient means. Note that the offset is not always +returned so if you want to use this data make sure to check for offset. If offset +is not present, the only way to get the image data is to perform a normal tag scan +without the environment variable set. + +One limitation that currently exists is that memory for embedded images is still +allocated for ASF and Ogg Vorbis files. + +This information is returned in different ways depending on the format: + +ID3 (MP3, AAC, WAV, AIFF): + + $tags->{APIC}->[3]: image length + $tags->{APIC}->[4]: image offset (unless APIC would need unsynchronization) + +MP4: + + $tags->{COVR}: image length + $tags->{COVR_offset}: image offset (always available) + +Ogg Vorbis: + + $tags->{ALLPICTURES}->[0]->{image_data}: image length + Image offset is not supported with Vorbis because the data is always base64-encoded. + +FLAC: + + $tags->{ALLPICTURES}->[0]->{image_data}: image length + $tags->{ALLPICTURES}->[0]->{offset}: image offset (always available) + +ASF: + + $tags->{'WM/Picture'}->{image}: image length + $tags->{'WM/Picture'}->{offset}: image offset (always available) + +APE, Musepack, WavPack, MP3 with APEv2: + + $tags->{'COVER ART (FRONT)'}: image length + $tags->{'COVER ART (FRONT)_offset'}: image offset (always available) + +=head1 MP3 + +=head2 INFO + +The following metadata about a file may be returned: + + id3_version (i.e. "ID3v2.4.0") + id3_was_unsynced (if a v2.2/v2.3 file needed whole-tag unsynchronization) + song_length_ms (duration in milliseconds) + layer (i.e. 3) + stereo + samples_per_frame + padding + audio_size (size of all audio frames) + audio_offset (byte offset to first audio frame) + bitrate (in bps, determined using Xing/LAME/VBRI if possible, or average in the worst case) + samplerate (in kHz) + vbr (1 if file is VBR) + dlna_profile (if file is compliant) + + If a Xing header is found: + xing_frames + xing_bytes + xing_quality + + If a VBRI header is found: + vbri_delay + vbri_frames + vbri_bytes + vbri_quality + + If a LAME header is found: + lame_encoder_version + lame_tag_revision + lame_vbr_method + lame_lowpass + lame_replay_gain_radio + lame_replay_gain_audiophile + lame_encoder_delay + lame_encoder_padding + lame_noise_shaping + lame_stereo_mode + lame_unwise_settings + lame_source_freq + lame_surround + lame_preset + +=head2 TAGS + +Raw tags are returned as found. This means older tags such as ID3v1 and ID3v2.2/v2.3 +are converted to ID3v2.4 tag names. Multiple instances of a tag in a file will be returned +as arrays. Complex tags such as APIC and COMM are returned as arrays. All tag fields are +converted to upper-case. All text is converted to UTF-8. + +Sample tag data: + + tags => { + ALBUMARTISTSORT => "Solar Fields", + APIC => [ "image/jpeg", 3, "", ], + CATALOGNUMBER => "INRE 017", + COMM => ["eng", "", "Amazon.com Song ID: 202981429"], + "MUSICBRAINZ ALBUM ARTIST ID" => "a2af1f31-c9eb-4fff-990c-c4f547a11b75", + "MUSICBRAINZ ALBUM ID" => "282143c9-6191-474d-a31a-1117b8c88cc0", + "MUSICBRAINZ ALBUM RELEASE COUNTRY" => "FR", + "MUSICBRAINZ ALBUM STATUS" => "official", + "MUSICBRAINZ ALBUM TYPE" => "album", + "MUSICBRAINZ ARTIST ID" => "a2af1f31-c9eb-4fff-990c-c4f547a11b75", + "REPLAYGAIN_ALBUM_GAIN" => "-2.96 dB", + "REPLAYGAIN_ALBUM_PEAK" => "1.045736", + "REPLAYGAIN_TRACK_GAIN" => "+3.60 dB", + "REPLAYGAIN_TRACK_PEAK" => "0.892606", + TALB => "Leaving Home", + TCOM => "Magnus Birgersson", + TCON => "Ambient", + TCOP => "2005 ULTIMAE RECORDS", + TDRC => "2004-10", + TIT2 => "Home", + TPE1 => "Solar Fields", + TPE2 => "Solar Fields", + TPOS => "1/1", + TPUB => "Ultimae Records", + TRCK => "1/11", + TSOP => "Solar Fields", + UFID => [ + "http://musicbrainz.org", + "1084278a-2254-4613-a03c-9fed7a8937ca", + ], + }, + + +=head1 MP4 + +=head2 INFO + +The following metadata about a file may be returned: + + audio_offset (byte offset to start of mdat) + audio_size + compatible_brands + file_size + leading_mdat (if file has mdat before moov) + major_brand + minor_version + song_length_ms + timescale + dlna_profile (if file is compliant) + tracks (array of tracks in the file) + Each track may contain: + + audio_type + avg_bitrate + bits_per_sample + channels + duration + encoding + handler_name + handler_type + id + max_bitrate + samplerate + +=head2 TAGS + +Tags are returned in a hash with all keys converted to upper-case. Keys starting with +0xA9 (copyright symbol) will have this character stripped out. Sample tag data: + + tags => { + AART => "Album Artist", + ALB => "Album", + ART => "Artist", + CMT => "Comments", + COVR => , + CPIL => 1, + DAY => 2009, + DESC => "Video Description", + DISK => "1/2", + "ENCODING PARAMS" => "vers\0\0\0\1acbf\0\0\0\2brat\0\1w\0cdcv\0\1\6\5", + GNRE => "Jazz", + GRP => "Grouping", + ITUNNORM => " 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000", + ITUNSMPB => " 00000000 00000840 000001E4 00000000000001DC 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000", + LYR => "Lyrics", + NAM => "Name", + PGAP => 1, + SOAA => "Sort Album Artist", + SOAL => "Sort Album", + SOAR => "Sort Artist", + SOCO => "Sort Composer", + SONM => "Sort Name", + SOSN => "Sort Show", + TMPO => 120, + TOO => "iTunes 8.1.1, QuickTime 7.6", + TRKN => "1/10", + TVEN => "Episode ID", + TVES => 12, + TVSH => "Show", + TVSN => 12, + WRT => "Composer", + }, + +=head1 AAC (ADTS) + +=head2 INFO + +The following metadata about a file is returned: + + audio_offset + audio_size + bitrate (in bps) + channels + file_size + profile (Main, LC, or SSR) + samplerate (in kHz) + song_length_ms (duration in milliseconds) + dlna_profile (if file is compliant) + +=head1 OGG VORBIS + +=head2 INFO + +The following metadata about a file is returned: + + version + channels + stereo + samplerate (in kHz) + bitrate_average (in bps) + bitrate_upper + bitrate_nominal + bitrate_lower + blocksize_0 + blocksize_1 + audio_offset (byte offset to audio) + audio_size + song_length_ms (duration in milliseconds) + +=head2 TAGS + +Raw Vorbis comments are returned. All comment keys are capitalized. + +=head1 FLAC + +=head2 INFO + +The following metadata about a file is returned: + + channels + samplerate (in kHz) + bitrate (in bps) + file_size + audio_offset (byte offset to first audio frame) + audio_size + song_length_ms (duration in milliseconds) + bits_per_sample + frames + minimum_blocksize + maximum_blocksize + minimum_framesize + maximum_framesize + audio_md5 + total_samples + +=head2 TAGS + +Raw FLAC comments are returned. All comment keys are capitalized. Some data returned is special: + +APPLICATION + + Each application block is returned in the APPLICATION tag keyed by application ID. + +CUESHEET_BLOCK + + The CUESHEET_BLOCK tag is an array containing each line of the cue sheet. + +ALLPICTURES + + Embedded pictures are returned in an ALLPICTURES array. Each picture has the following metadata: + + mime_type + description + width + height + depth + color_index + image_data + picture_type + +=head1 ASF (Windows Media Audio/Video) + +=head2 INFO + +The following metadata about a file may be returned. Reading the ASF spec is encouraged if you +want to find out more about any of these values. + + audio_offset (byte offset to first data packet) + audio_size + broadcast (boolean, whether the file is a live broadcast or not) + codec_list (array of information about codecs used in the file) + creation_date (UNIX timestamp when file was created) + data_packets + drm_key + drm_license_url + drm_protection_type + drm_data + file_id (unique file ID) + file_size + index_blocks + index_entry_interval (in milliseconds) + index_offsets (byte offsets for each second of audio, per stream. Useful for seeking) + index_specifiers (indicates which stream a given index_offset points to) + language_list (array of languages referenced by the file's metadata) + lossless (boolean) + max_bitrate + max_packet_size + min_packet_size + mutex_list (mutually exclusive stream information) + play_duration_ms + preroll + script_commands + script_types + seekable (boolean, whether the file is seekable or not) + send_duration_ms + song_length_ms (the actual length of the audio, in milliseconds) + dlna_profile (if file is compliant) + +STREAMS + +The streams array contains metadata related to an individul stream within the file. +The following metadata may be returned: + + DeviceConformanceTemplate + IsVBR + alt_bitrate + alt_buffer_fullness + alt_buffer_size + avg_bitrate (most accurate bitrate for this stream) + avg_bytes_per_sec (audio only) + bitrate + bits_per_sample (audio only) + block_alignment (audio only) + bpp (video only) + buffer_fullness + buffer_size + channels (audio only) + codec_id (audio only) + compression_id (video only) + encode_options + encrypted (boolean) + error_correction_type + flag_seekable (boolean) + height (video only) + index_type + language_index (offset into language_list array) + max_object_size + samplerate (in kHz) (audio only) + samples_per_block + stream_number + stream_type + super_block_align + time_offset + width (video only) + +=head2 TAGS + +Raw tags are returned. Tags that occur more than once are returned as arrays. +In contrast to the other formats, tag keys are NOT capitalized. There is one special key: + +WM/Picture + +Pictures are returned as a hash with the following keys: + + image_type (numeric type, same as ID3v2 APIC) + mime_type + description + image + +=head1 WAV + +=head2 INFO + +The following metadata about a file may be returned. + + audio_offset + audio_size + bitrate (in bps) + bits_per_sample + block_align + channels + dlna_profile (if file is compliant) + file_size + format (WAV format code, 1 == PCM) + id3_version (if an ID3v2 tag is found) + samplerate (in kHz) + song_length_ms + +=head2 TAGS + +WAV files can contain several different types of tags. "Native" WAV tags +found in a LIST block may include these and others: + + IARL - Archival Location + IART - Artist + ICMS - Commissioned + ICMT - Comment + ICOP - Copyright + ICRD - Creation Date + ICRP - Cropped + IENG - Engineer + IGNR - Genre + IKEY - Keywords + IMED - Medium + INAM - Name (Title) + IPRD - Product (Album) + ISBJ - Subject + ISFT - Software + ISRC - Source + ISRF - Source Form + TORG - Label + LOCA - Location + TVER - Version + TURL - URL + TLEN - Length + ITCH - Technician + TRCK - Track + ITRK - Track + +ID3v2 tags can also be embedded within WAV files. These are returned exactly as for MP3 files. + +=head1 AIFF + +=head2 INFO + +The following metadata about a file may be returned. + + audio_offset + audio_size + bitrate (in bps) + bits_per_sample + block_align + channels + compression_name (if AIFC) + compression_type (if AIFC) + dlna_profile (if file is compliant) + file_size + id3_version (if an ID3v2 tag is found) + samplerate (in kHz) + song_length_ms + +=head2 TAGS + +ID3v2 tags can be embedded within AIFF files. These are returned exactly as for MP3 files. + +=head1 MONKEY'S AUDIO (APE) + +=head2 INFO + +The following metadata about a file may be returned. + + audio_offset + audio_size + bitrate (in bps) + channels + compression + file_size + samplerate (in kHz) + song_length_ms + version + +=head2 TAGS + +APEv2 tags are returned as a hash of key/value pairs. + +=head1 MUSEPACK + +=head2 INFO + +The following metadata about a file may be returned. + + audio_offset + audio_size + bitrate (in bps) + channels + encoder + file_size + profile + samplerate (in kHz) + song_length_ms + +=head2 TAGS + +Musepack uses APEv2 tags. They are returned as a hash of key/value pairs. + +=head1 WAVPACK + +=head2 INFO + +The following metadata about a file may be returned. + + audio_offset + audio_size + bitrate (in bps) + bits_per_sample + channels + encoder_version + file_size + hybrid (1 if file is lossy) (v4 only) + lossless (1 if file is lossless) (v4 only) + samplerate + song_length_ms + total_samples + +=head2 TAGS + +WavPack uses APEv2 tags. They are returned as a hash of key/value pairs. + +=head1 DSF + +=head2 INFO + +The following metadata about a file may be returned. + + audio_offset + audio_size + bits_per_sample + channels + song_length_ms + samplerate + block_size_per_channel + +=head2 TAGS + +ID3v2 tags can be embedded within DSF files. These are returned exactly as for MP3 files. + +=head1 DSDIFF (DFF) + +=head2 INFO + +The following metadata about a file may be returned. + + audio_offset + audio_size + bits_per_sample + channels + song_length_ms + samplerate + tag_diti_title + tag_diar_artist + +=head2 TAGS + +No separate tags are supported by the DSDIFF format. + +=head1 + +=head1 THANKS + +Logitech & Slim Devices, for letting us release so much of our code to the world. +Long live Squeezebox! + +Kimmo Taskinen, Adrian Smith, Clive Messer, and Jurgen Kramer for +DSF/DSDIFF support and various other fixes. + +Some code from the Rockbox project was very helpful in implementing ASF and +MP4 seeking. + +Some of the file format parsing code was derived from the mt-daapd project, +and adapted by Netgear. It has been heavily rewritten to fix bugs and add +more features. + +The source to the original Netgear C scanner for SqueezeCenter is located +at L + +The audio MD5 feature uses an MD5 implementation by L. Peter Deutsch, +Eghost@aladdin.comE. + +=head1 SEE ALSO + +ASF Spec L + +MP4 Info: +L +L + +=head1 AUTHORS + +Andy Grundman, Eandy@hybridized.orgE + +Dan Sully, Edaniel@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010-2011 Logitech, Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +=cut diff --git a/CPAN/arch/5.42/Class/XSAccessor.pm b/CPAN/arch/5.42/Class/XSAccessor.pm new file mode 100644 index 00000000000..2ef7979005a --- /dev/null +++ b/CPAN/arch/5.42/Class/XSAccessor.pm @@ -0,0 +1,326 @@ +package Class::XSAccessor; +use 5.008; +use strict; +use warnings; +use Carp qw/croak/; +use Class::XSAccessor::Heavy; +use XSLoader; + +our $VERSION = '1.18'; + +XSLoader::load('Class::XSAccessor', $VERSION); + +sub _make_hash { + my $ref = shift; + + if (ref ($ref)) { + if (ref($ref) eq 'ARRAY') { + $ref = { map { $_ => $_ } @$ref } + } + } else { + $ref = { $ref, $ref }; + } + + return $ref; +} + +sub import { + my $own_class = shift; + my ($caller_pkg) = caller(); + + # Support both { getters => ... } and plain getters => ... + my %opts = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_; + + $caller_pkg = $opts{class} if defined $opts{class}; + + # TODO: Refactor. Move more duplicated code to ::Heavy + my $read_subs = _make_hash($opts{getters} || {}); + my $set_subs = _make_hash($opts{setters} || {}); + my $acc_subs = _make_hash($opts{accessors} || {}); + my $lvacc_subs = _make_hash($opts{lvalue_accessors} || {}); + my $pred_subs = _make_hash($opts{predicates} || {}); + my $ex_pred_subs = _make_hash($opts{exists_predicates} || {}); + my $def_pred_subs = _make_hash($opts{defined_predicates} || {}); + my $test_subs = _make_hash($opts{__tests__} || {}); + my $construct_subs = $opts{constructors} || [defined($opts{constructor}) ? $opts{constructor} : ()]; + my $true_subs = $opts{true} || []; + my $false_subs = $opts{false} || []; + + foreach my $subtype ( ["getter", $read_subs], + ["setter", $set_subs], + ["accessor", $acc_subs], + ["lvalue_accessor", $lvacc_subs], + ["test", $test_subs], + ["ex_predicate", $ex_pred_subs], + ["def_predicate", $def_pred_subs], + ["def_predicate", $pred_subs] ) + { + my $subs = $subtype->[1]; + foreach my $subname (keys %$subs) { + my $hashkey = $subs->{$subname}; + _generate_method($caller_pkg, $subname, $hashkey, \%opts, $subtype->[0]); + } + } + + foreach my $subtype ( ["constructor", $construct_subs], + ["true", $true_subs], + ["false", $false_subs] ) + { + foreach my $subname (@{$subtype->[1]}) { + _generate_method($caller_pkg, $subname, "", \%opts, $subtype->[0]); + } + } +} + +sub _generate_method { + my ($caller_pkg, $subname, $hashkey, $opts, $type) = @_; + + croak("Cannot use undef as a hash key for generating an XS $type accessor. (Sub: $subname)") + if not defined $hashkey; + + $subname = "${caller_pkg}::$subname" if $subname !~ /::/; + + Class::XSAccessor::Heavy::check_sub_existence($subname) if not $opts->{replace}; + no warnings 'redefine'; # don't warn about an explicitly requested redefine + + if ($type eq 'getter') { + newxs_getter($subname, $hashkey); + } + elsif ($type eq 'lvalue_accessor') { + newxs_lvalue_accessor($subname, $hashkey); + } + elsif ($type eq 'setter') { + newxs_setter($subname, $hashkey, $opts->{chained}||0); + } + elsif ($type eq 'def_predicate') { + newxs_defined_predicate($subname, $hashkey); + } + elsif ($type eq 'ex_predicate') { + newxs_exists_predicate($subname, $hashkey); + } + elsif ($type eq 'constructor') { + newxs_constructor($subname); + } + elsif ($type eq 'true') { + newxs_boolean($subname, 1); + } + elsif ($type eq 'false') { + newxs_boolean($subname, 0); + } + elsif ($type eq 'test') { + newxs_test($subname, $hashkey); + } + else { + newxs_accessor($subname, $hashkey, $opts->{chained}||0); + } +} + +1; + +__END__ + +=head1 NAME + +Class::XSAccessor - Generate fast XS accessors without runtime compilation + +=head1 SYNOPSIS + + package MyClass; + use Class::XSAccessor + replace => 1, # Replace existing methods (if any) + constructor => 'new', + getters => { + get_foo => 'foo', # 'foo' is the hash key to access + get_bar => 'bar', + }, + setters => { + set_foo => 'foo', + set_bar => 'bar', + }, + accessors => { + foo => 'foo', + bar => 'bar', + }, + # "predicates" is an alias for "defined_predicates" + defined_predicates => { + defined_foo => 'foo', + defined_bar => 'bar', + }, + exists_predicates => { + has_foo => 'foo', + has_bar => 'bar', + }, + lvalue_accessors => { # see below + baz => 'baz', # ... + }, + true => [ 'is_token', 'is_whitespace' ], + false => [ 'significant' ]; + + # The imported methods are implemented in fast XS. + + # normal class code here. + +As of version 1.05, some alternative syntax forms are available: + + package MyClass; + + # Options can be passed as a HASH reference, if preferred, + # which can also help Perl::Tidy to format the statement correctly. + use Class::XSAccessor { + # If the name => key values are always identical, + # the following shorthand can be used. + accessors => [ 'foo', 'bar' ], + }; + +=head1 DESCRIPTION + +Class::XSAccessor implements fast read, write and read/write accessors in XS. +Additionally, it can provide predicates such as C for testing +whether the attribute C exists in the object (which is different from +"is defined within the object"). +It only works with objects that are implemented as ordinary hashes. +L implements the same interface for objects +that use arrays for their internal representation. + +Since version 0.10, the module can also generate simple constructors +(implemented in XS). Simply supply the +C 'constructor_name'> option or the +C ['new', 'create', 'spawn']> option. +These constructors do the equivalent of the following Perl code: + + sub new { + my $class = shift; + return bless { @_ }, ref($class)||$class; + } + +That means they can be called on objects and classes but will not +clone objects entirely. Parameters to C are added to the +object. + +The XS accessor methods are between 3 and 4 times faster than typical +pure-Perl accessors in some simple benchmarking. +The lower factor applies to the potentially slightly obscure +C{foo} = $_[1]}>, so if you usually +write clear code, a factor of 3.5 speed-up is a good estimate. +If in doubt, do your own benchmarking! + +The method names may be fully qualified. The example in the synopsis could +have been written as C instead +of C. This way, methods can be installed in classes other +than the current class. See also: the C option below. + +By default, the setters return the new value that was set, +and the accessors (mutators) do the same. This behaviour can be changed +with the C option - see below. The predicates return a boolean. + +Since version 1.01, C can generate extremely simple methods which +just return true or false (and always do so). If that seems like a +really superfluous thing to you, then consider a large class hierarchy +with interfaces such as L. These methods are provided by the C +and C options - see the synopsis. + +C check whether a given object attribute is defined. +C is an alias for C for compatibility with +older versions of C. C checks +whether the given attribute exists in the object using C. + +=head1 OPTIONS + +In addition to specifying the types and names of accessors, additional options +can be supplied which modify behaviour. The options are specified as key/value pairs +in the same manner as the accessor declaration. For example: + + use Class::XSAccessor + getters => { + get_foo => 'foo', + }, + replace => 1; + +The list of available options is: + +=head2 replace + +Set this to a true value to prevent C from +complaining about replacing existing subroutines. + +=head2 chained + +Set this to a true value to change the return value of setters +and mutators (when called with an argument). +If C is enabled, the setters and accessors/mutators will +return the object. Mutators called without an argument still +return the value of the associated attribute. + +As with the other options, C affects all methods generated +in the same C statement. + +=head2 class + +By default, the accessors are generated in the calling class. The +the C option allows the target class to be specified. + +=head1 LVALUES + +Support for lvalue accessors via the keyword C +was added in version 1.08. At this point, B. Furthermore, their performance hasn't been benchmarked +yet. + +The following example demonstrates an lvalue accessor: + + package Address; + use Class::XSAccessor + constructor => 'new', + lvalue_accessors => { zip_code => 'zip' }; + + package main; + my $address = Address->new(zip => 2); + print $address->zip_code, "\n"; # prints 2 + $address->zip_code = 76135; # <--- This is it! + print $address->zip_code, "\n"; # prints 76135 + +=head1 CAVEATS + +Probably won't work for objects based on I hashes. But that's a strange thing to do anyway. + +Scary code exploiting strange XS features. + +If you think writing an accessor in XS should be a laughably simple exercise, then +please contemplate how you could instantiate a new XS accessor for a new hash key +that's only known at run-time. Note that compiling C code at run-time a la L +is a no go. + +Threading. With version 1.00, a memory leak has been B. Previously, a small amount of +memory would leak if C-based classes were loaded in a subthread without having +been loaded in the "main" thread. If the subthread then terminated, a hash key and an int per +associated method used to be lost. Note that this mattered only if classes were B loaded +in a sort of throw-away thread. + +In the new implementation, as of 1.00, the memory will still not be released, in the same situation, +but it will be recycled when the same class, or a similar class, is loaded again in B thread. + +=head1 SEE ALSO + +=over + +=item * L + +=item * L + +=back + +=head1 AUTHOR + +Steffen Mueller Esmueller@cpan.orgE + +chocolateboy Echocolate@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 by Steffen Mueller + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/CPAN/arch/5.42/Class/XSAccessor/Array.pm b/CPAN/arch/5.42/Class/XSAccessor/Array.pm new file mode 100644 index 00000000000..05035bedb78 --- /dev/null +++ b/CPAN/arch/5.42/Class/XSAccessor/Array.pm @@ -0,0 +1,284 @@ +package Class::XSAccessor::Array; +use 5.008; +use strict; +use warnings; +use Carp qw/croak/; +use Class::XSAccessor; +use Class::XSAccessor::Heavy; + +our $VERSION = '1.18'; + +sub import { + my $own_class = shift; + my ($caller_pkg) = caller(); + + # Support both { getters => ... } and plain getters => ... + my %opts = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_; + + $caller_pkg = $opts{class} if defined $opts{class}; + + my $read_subs = $opts{getters} || {}; + my $set_subs = $opts{setters} || {}; + my $acc_subs = $opts{accessors} || {}; + my $lvacc_subs = $opts{lvalue_accessors} || {}; + my $pred_subs = $opts{predicates} || {}; + my $construct_subs = $opts{constructors} || [defined($opts{constructor}) ? $opts{constructor} : ()]; + my $true_subs = $opts{true} || []; + my $false_subs = $opts{false} || []; + + + foreach my $subtype ( ["getter", $read_subs], + ["setter", $set_subs], + ["accessor", $acc_subs], + ["lvalue_accessor", $lvacc_subs], + ["pred_subs", $pred_subs] ) + { + my $subs = $subtype->[1]; + foreach my $subname (keys %$subs) { + my $array_index = $subs->{$subname}; + _generate_method($caller_pkg, $subname, $array_index, \%opts, $subtype->[0]); + } + } + + foreach my $subtype ( ["constructor", $construct_subs], + ["true", $true_subs], + ["false", $false_subs] ) + { + foreach my $subname (@{$subtype->[1]}) { + _generate_method($caller_pkg, $subname, "", \%opts, $subtype->[0]); + } + } +} + +sub _generate_method { + my ($caller_pkg, $subname, $array_index, $opts, $type) = @_; + + croak("Cannot use undef as a array index for generating an XS $type accessor. (Sub: $subname)") + if not defined $array_index; + + $subname = "${caller_pkg}::$subname" if $subname !~ /::/; + + Class::XSAccessor::Heavy::check_sub_existence($subname) if not $opts->{replace}; + no warnings 'redefine'; # don't warn about an explicitly requested redefine + + if ($type eq 'getter') { + newxs_getter($subname, $array_index); + } + if ($type eq 'lvalue_accessor') { + newxs_lvalue_accessor($subname, $array_index); + } + elsif ($type eq 'setter') { + newxs_setter($subname, $array_index, $opts->{chained}||0); + } + elsif ($type eq 'predicate') { + newxs_predicate($subname, $array_index); + } + elsif ($type eq 'constructor') { + newxs_constructor($subname); + } + elsif ($type eq 'true') { + Class::XSAccessor::newxs_boolean($subname, 1); + } + elsif ($type eq 'false') { + Class::XSAccessor::newxs_boolean($subname, 0); + } + else { + newxs_accessor($subname, $array_index, $opts->{chained}||0); + } +} + +1; + +__END__ + +=head1 NAME + +Class::XSAccessor::Array - Generate fast XS accessors without runtime compilation + +=head1 SYNOPSIS + + package MyClassUsingArraysAsInternalStorage; + use Class::XSAccessor::Array + constructor => 'new', + getters => { + get_foo => 0, # 0 is the array index to access + get_bar => 1, + }, + setters => { + set_foo => 0, + set_bar => 1, + }, + accessors => { # a mutator + buz => 2, + }, + predicates => { # test for definedness + has_buz => 2, + }, + lvalue_accessors => { # see below + baz => 3, + }, + true => [ 'is_token', 'is_whitespace' ], + false => [ 'significant' ]; + + # The imported methods are implemented in fast XS. + + # normal class code here. + +As of version 1.05, some alternative syntax forms are available: + + package MyClass; + + # Options can be passed as a HASH reference if you prefer it, + # which can also help PerlTidy to flow the statement correctly. + use Class::XSAccessor { + getters => { + get_foo => 0, + get_bar => 1, + }, + }; + +=head1 DESCRIPTION + +The module implements fast XS accessors both for getting at and +setting an object attribute. Additionally, the module supports +mutators and simple predicates (C like tests for definedness +of an attributes). +The module works only with objects +that are implemented as B. Using it on hash-based objects is +bound to make your life miserable. Refer to L for +an implementation that works with hash-based objects. + +A simple benchmark showed a significant performance +advantage over writing accessors in Perl. + +Since version 0.10, the module can also generate simple constructors +(implemented in XS) for you. Simply supply the +C 'constructor_name'> option or the +C ['new', 'create', 'spawn']> option. +These constructors do the equivalent of the following Perl code: + + sub new { + my $class = shift; + return bless [], ref($class)||$class; + } + +That means they can be called on objects and classes but will not +clone objects entirely. Note that any parameters to new() will be +discarded! If there is a better idiom for array-based objects, let +me know. + +While generally more obscure than hash-based objects, +objects using blessed arrays as internal representation +are a bit faster as its somewhat faster to access arrays than hashes. +Accordingly, this module is slightly faster (~10-15%) than +L, which works on hash-based objects. + +The method names may be fully qualified. In the example of the +synopsis, you could have written C instead +of C. This way, you can install methods in classes other +than the current class. See also: The C option below. + +Since version 1.01, you can generate extremely simple methods which +just return true or false (and always do so). If that seems like a +really superfluous thing to you, then think of a large class hierarchy +with interfaces such as PPI. This is implemented as the C +and C options, see synopsis. + +=head1 OPTIONS + +In addition to specifying the types and names of accessors, you can add options +which modify behaviour. The options are specified as key/value pairs just as the +accessor declaration. Example: + + use Class::XSAccessor::Array + getters => { + get_foo => 0, + }, + replace => 1; + +The list of available options is: + +=head2 replace + +Set this to a true value to prevent C from +complaining about replacing existing subroutines. + +=head2 chained + +Set this to a true value to change the return value of setters +and mutators (when called with an argument). +If C is enabled, the setters and accessors/mutators will +return the object. Mutators called without an argument still +return the value of the associated attribute. + +As with the other options, C affects all methods generated +in the same C statement. + +=head2 class + +By default, the accessors are generated in the calling class. Using +the C option, you can explicitly specify where the methods +are to be generated. + +=head1 LVALUES + +Support for lvalue accessors via the keyword C +was added in version 1.08. At this point, B. Furthermore, their performance hasn't been benchmarked +yet. + +The following example demonstrates an lvalue accessor: + + package Address; + use Class::XSAccessor + constructor => 'new', + lvalue_accessors => { zip_code => 0 }; + + package main; + my $address = Address->new(2); + print $address->zip_code, "\n"; # prints 2 + $address->zip_code = 76135; # <--- This is it! + print $address->zip_code, "\n"; # prints 76135 + +=head1 CAVEATS + +Probably wouldn't work if your objects are I. But that's a strange thing to do anyway. + +Scary code exploiting strange XS features. + +If you think writing an accessor in XS should be a laughably simple exercise, then +please contemplate how you could instantiate a new XS accessor for a new hash key +or array index that's only known at run-time. Note that compiling C code at run-time +a la Inline::C is a no go. + +Threading. With version 1.00, a memory leak has been B that would leak a small amount of +memory if you loaded C-based classes in a subthread that hadn't been loaded +in the "main" thread before. If the subthread then terminated, a hash key and an int per +associated method used ot be lost. Note that this mattered only if classes were B loaded +in a sort of throw-away thread. + +In the new implementation as of 1.00, the memory will not be released again either in the above +situation. But it will be recycled when the same class or a similar class is loaded +again in B thread. + +=head1 SEE ALSO + +L + +L + +=head1 AUTHOR + +Steffen Mueller Esmueller@cpan.orgE + +chocolateboy Echocolate@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 by Steffen Mueller + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/CPAN/arch/5.42/Class/XSAccessor/Heavy.pm b/CPAN/arch/5.42/Class/XSAccessor/Heavy.pm new file mode 100644 index 00000000000..7b74b145cef --- /dev/null +++ b/CPAN/arch/5.42/Class/XSAccessor/Heavy.pm @@ -0,0 +1,76 @@ +package # hide from PAUSE + Class::XSAccessor::Heavy; + +use 5.008; +use strict; +use warnings; +use Carp; + +our $VERSION = '1.18'; +our @CARP_NOT = qw( + Class::XSAccessor + Class::XSAccessor::Array +); + +# TODO Move more duplicated code from XSA and XSA::Array here + + +sub check_sub_existence { + my $subname = shift; + + my $sub_package = $subname; + $sub_package =~ s/([^:]+)$// or die; + my $bare_subname = $1; + + my $sym; + { + no strict 'refs'; + $sym = \%{"$sub_package"}; + } + no warnings; + local *s = $sym->{$bare_subname}; + my $coderef = *s{CODE}; + if ($coderef) { + $sub_package =~ s/::$//; + Carp::croak("Cannot replace existing subroutine '$bare_subname' in package '$sub_package' with an XS implementation. If you wish to force a replacement, add the 'replace => 1' parameter to the arguments of 'use ".(caller())[0]."'."); + } +} + +1; + +__END__ + +=head1 NAME + +Class::XSAccessor::Heavy - Guts you don't care about + +=head1 SYNOPSIS + + use Class::XSAccessor! + +=head1 DESCRIPTION + +Common guts for Class::XSAccessor and Class::XSAccessor::Array. +No user-serviceable parts inside! + +=head1 SEE ALSO + +L +L + +=head1 AUTHOR + +Steffen Mueller, Esmueller@cpan.orgE + +chocolateboy, Echocolate@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 by Steffen Mueller + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8 or, +at your option, any later version of Perl 5 you may have available. + +=cut + diff --git a/CPAN/arch/5.42/DBD/DBM.pm b/CPAN/arch/5.42/DBD/DBM.pm new file mode 100644 index 00000000000..a8fe8b9a00c --- /dev/null +++ b/CPAN/arch/5.42/DBD/DBM.pm @@ -0,0 +1,1454 @@ +####################################################################### +# +# DBD::DBM - a DBI driver for DBM files +# +# Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org > +# Copyright (c) 2010-2013 by Jens Rehsack & H.Merijn Brand +# +# All rights reserved. +# +# You may freely distribute and/or modify this module under the terms +# of either the GNU General Public License (GPL) or the Artistic License, +# as specified in the Perl README file. +# +# USERS - see the pod at the bottom of this file +# +# DBD AUTHORS - see the comments in the code +# +####################################################################### +require 5.008; +use strict; + +################# +package DBD::DBM; +################# +use base qw( DBD::File ); +use vars qw($VERSION $ATTRIBUTION $drh $methods_already_installed); +$VERSION = '0.08'; +$ATTRIBUTION = 'DBD::DBM by Jens Rehsack'; + +# no need to have driver() unless you need private methods +# +sub driver ($;$) +{ + my ( $class, $attr ) = @_; + return $drh if ($drh); + + # do the real work in DBD::File + # + $attr->{Attribution} = 'DBD::DBM by Jens Rehsack'; + $drh = $class->SUPER::driver($attr); + + # install private methods + # + # this requires that dbm_ (or foo_) be a registered prefix + # but you can write private methods before official registration + # by hacking the $dbd_prefix_registry in a private copy of DBI.pm + # + unless ( $methods_already_installed++ ) + { + DBD::DBM::st->install_method('dbm_schema'); + } + + return $drh; +} + +sub CLONE +{ + undef $drh; +} + +##################### +package DBD::DBM::dr; +##################### +$DBD::DBM::dr::imp_data_size = 0; +@DBD::DBM::dr::ISA = qw(DBD::File::dr); + +# you could put some :dr private methods here + +# you may need to over-ride some DBD::File::dr methods here +# but you can probably get away with just letting it do the work +# in most cases + +##################### +package DBD::DBM::db; +##################### +$DBD::DBM::db::imp_data_size = 0; +@DBD::DBM::db::ISA = qw(DBD::File::db); + +use Carp qw/carp/; + +sub validate_STORE_attr +{ + my ( $dbh, $attrib, $value ) = @_; + + if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" ) + { + ( my $newattrib = $attrib ) =~ s/^dbm_/f_/g; + carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if ($^W); + $attrib = $newattrib; + } + + return $dbh->SUPER::validate_STORE_attr( $attrib, $value ); +} + +sub validate_FETCH_attr +{ + my ( $dbh, $attrib ) = @_; + + if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" ) + { + ( my $newattrib = $attrib ) =~ s/^dbm_/f_/g; + carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if ($^W); + $attrib = $newattrib; + } + + return $dbh->SUPER::validate_FETCH_attr($attrib); +} + +sub set_versions +{ + my $this = $_[0]; + $this->{dbm_version} = $DBD::DBM::VERSION; + return $this->SUPER::set_versions(); +} + +sub init_valid_attributes +{ + my $dbh = shift; + + # define valid private attributes + # + # attempts to set non-valid attrs in connect() or + # with $dbh->{attr} will throw errors + # + # the attrs here *must* start with dbm_ or foo_ + # + # see the STORE methods below for how to check these attrs + # + $dbh->{dbm_valid_attrs} = { + dbm_type => 1, # the global DBM type e.g. SDBM_File + dbm_mldbm => 1, # the global MLDBM serializer + dbm_cols => 1, # the global column names + dbm_version => 1, # verbose DBD::DBM version + dbm_store_metadata => 1, # column names, etc. + dbm_berkeley_flags => 1, # for BerkeleyDB + dbm_valid_attrs => 1, # DBD::DBM::db valid attrs + dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs + dbm_meta => 1, # DBD::DBM public access for f_meta + dbm_tables => 1, # DBD::DBM public access for f_meta + }; + $dbh->{dbm_readonly_attrs} = { + dbm_version => 1, # verbose DBD::DBM version + dbm_valid_attrs => 1, # DBD::DBM::db valid attrs + dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs + dbm_meta => 1, # DBD::DBM public access for f_meta + }; + + $dbh->{dbm_meta} = "dbm_tables"; + + return $dbh->SUPER::init_valid_attributes(); +} + +sub init_default_attributes +{ + my ( $dbh, $phase ) = @_; + + $dbh->SUPER::init_default_attributes($phase); + $dbh->{f_lockfile} = '.lck'; + + return $dbh; +} + +sub get_dbm_versions +{ + my ( $dbh, $table ) = @_; + $table ||= ''; + + my $meta; + my $class = $dbh->{ImplementorClass}; + $class =~ s/::db$/::Table/; + $table and ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); + $meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table ) ); + + my $dver; + my $dtype = $meta->{dbm_type}; + eval { + $dver = $meta->{dbm_type}->VERSION(); + + # *) when we're still alive here, everything went ok - no need to check for $@ + $dtype .= " ($dver)"; + }; + if ( $meta->{dbm_mldbm} ) + { + $dtype .= ' + MLDBM'; + eval { + $dver = MLDBM->VERSION(); + $dtype .= " ($dver)"; # (*) + }; + eval { + my $ser_class = "MLDBM::Serializer::" . $meta->{dbm_mldbm}; + my $ser_mod = $ser_class; + $ser_mod =~ s|::|/|g; + $ser_mod .= ".pm"; + require $ser_mod; + $dver = $ser_class->VERSION(); + $dtype .= ' + ' . $ser_class; # (*) + $dver and $dtype .= " ($dver)"; # (*) + }; + } + return sprintf( "%s using %s", $dbh->{dbm_version}, $dtype ); +} + +# you may need to over-ride some DBD::File::db methods here +# but you can probably get away with just letting it do the work +# in most cases + +##################### +package DBD::DBM::st; +##################### +$DBD::DBM::st::imp_data_size = 0; +@DBD::DBM::st::ISA = qw(DBD::File::st); + +sub FETCH +{ + my ( $sth, $attr ) = @_; + + if ( $attr eq "NULLABLE" ) + { + my @colnames = $sth->sql_get_colnames(); + + # XXX only BerkeleyDB fails having NULL values for non-MLDBM databases, + # none accept it for key - but it requires more knowledge between + # queries and tables storage to return fully correct information + $attr eq "NULLABLE" and return [ map { 0 } @colnames ]; + } + + return $sth->SUPER::FETCH($attr); +} # FETCH + +sub dbm_schema +{ + my ( $sth, $tname ) = @_; + return $sth->set_err( $DBI::stderr, 'No table name supplied!' ) unless $tname; + my $tbl_meta = $sth->{Database}->func( $tname, "f_schema", "get_sql_engine_meta" ) + or return $sth->set_err( $sth->{Database}->err(), $sth->{Database}->errstr() ); + return $tbl_meta->{$tname}->{f_schema}; +} +# you could put some :st private methods here + +# you may need to over-ride some DBD::File::st methods here +# but you can probably get away with just letting it do the work +# in most cases + +############################ +package DBD::DBM::Statement; +############################ + +@DBD::DBM::Statement::ISA = qw(DBD::File::Statement); + +######################## +package DBD::DBM::Table; +######################## +use Carp; +use Fcntl; + +@DBD::DBM::Table::ISA = qw(DBD::File::Table); + +my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir'; + +my %reset_on_modify = ( + dbm_type => "dbm_tietype", + dbm_mldbm => "dbm_tietype", + ); +__PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + +my %compat_map = ( + ( map { $_ => "dbm_$_" } qw(type mldbm store_metadata) ), + dbm_ext => 'f_ext', + dbm_file => 'f_file', + dbm_lockfile => ' f_lockfile', + ); +__PACKAGE__->register_compat_map( \%compat_map ); + +sub bootstrap_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_; + + $meta->{dbm_type} ||= $dbh->{dbm_type} || 'SDBM_File'; + $meta->{dbm_mldbm} ||= $dbh->{dbm_mldbm} if ( $dbh->{dbm_mldbm} ); + $meta->{dbm_berkeley_flags} ||= $dbh->{dbm_berkeley_flags}; + + defined $meta->{f_ext} + or $meta->{f_ext} = $dbh->{f_ext}; + unless ( defined( $meta->{f_ext} ) ) + { + my $ext; + if ( $meta->{dbm_type} eq 'SDBM_File' or $meta->{dbm_type} eq 'ODBM_File' ) + { + $ext = '.pag/r'; + } + elsif ( $meta->{dbm_type} eq 'NDBM_File' ) + { + # XXX NDBM_File on FreeBSD (and elsewhere?) may actually be Berkeley + # behind the scenes and so create a single .db file. + if ( $^O =~ /bsd/i or lc($^O) eq 'darwin' ) + { + $ext = '.db/r'; + } + elsif ( $^O eq 'SunOS' or $^O eq 'Solaris' or $^O eq 'AIX' ) + { + $ext = '.pag/r'; # here it's implemented like dbm - just a bit improved + } + # else wrapped GDBM + } + defined($ext) and $meta->{f_ext} = $ext; + } + + $self->SUPER::bootstrap_table_meta( $dbh, $meta, $table ); +} + +sub init_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_; + + $meta->{f_dontopen} = 1; + + unless ( defined( $meta->{dbm_tietype} ) ) + { + my $tie_type = $meta->{dbm_type}; + $INC{"$tie_type.pm"} or require "$tie_type.pm"; + $tie_type eq 'BerkeleyDB' and $tie_type = 'BerkeleyDB::Hash'; + + if ( $meta->{dbm_mldbm} ) + { + $INC{"MLDBM.pm"} or require "MLDBM.pm"; + $meta->{dbm_usedb} = $tie_type; + $tie_type = 'MLDBM'; + } + + $meta->{dbm_tietype} = $tie_type; + } + + unless ( defined( $meta->{dbm_store_metadata} ) ) + { + my $store = $dbh->{dbm_store_metadata}; + defined($store) or $store = 1; + $meta->{dbm_store_metadata} = $store; + } + + unless ( defined( $meta->{col_names} ) ) + { + defined( $dbh->{dbm_cols} ) and $meta->{col_names} = $dbh->{dbm_cols}; + } + + $self->SUPER::init_table_meta( $dbh, $meta, $table ); +} + +sub open_data +{ + my ( $className, $meta, $attrs, $flags ) = @_; + $className->SUPER::open_data( $meta, $attrs, $flags ); + + unless ( $flags->{dropMode} ) + { + # TIEING + # + # XXX allow users to pass in a pre-created tied object + # + my @tie_args; + if ( $meta->{dbm_type} eq 'BerkeleyDB' ) + { + my $DB_CREATE = BerkeleyDB::DB_CREATE(); + my $DB_RDONLY = BerkeleyDB::DB_RDONLY(); + my %tie_flags; + if ( my $f = $meta->{dbm_berkeley_flags} ) + { + defined( $f->{DB_CREATE} ) and $DB_CREATE = delete $f->{DB_CREATE}; + defined( $f->{DB_RDONLY} ) and $DB_RDONLY = delete $f->{DB_RDONLY}; + %tie_flags = %$f; + } + my $open_mode = $flags->{lockMode} || $flags->{createMode} ? $DB_CREATE : $DB_RDONLY; + @tie_args = ( + -Filename => $meta->{f_fqbn}, + -Flags => $open_mode, + %tie_flags + ); + } + else + { + my $open_mode = O_RDONLY; + $flags->{lockMode} and $open_mode = O_RDWR; + $flags->{createMode} and $open_mode = O_RDWR | O_CREAT | O_TRUNC; + + @tie_args = ( $meta->{f_fqbn}, $open_mode, 0666 ); + } + + if ( $meta->{dbm_mldbm} ) + { + $MLDBM::UseDB = $meta->{dbm_usedb}; + $MLDBM::Serializer = $meta->{dbm_mldbm}; + } + + $meta->{hash} = {}; + my $tie_class = $meta->{dbm_tietype}; + eval { tie %{ $meta->{hash} }, $tie_class, @tie_args }; + $@ and croak "Cannot tie(\%h $tie_class @tie_args): $@"; + -f $meta->{f_fqfn} or croak( "No such file: '" . $meta->{f_fqfn} . "'" ); + } + + unless ( $flags->{createMode} ) + { + my ( $meta_data, $schema, $col_names ); + if ( $meta->{dbm_store_metadata} ) + { + $meta_data = $col_names = $meta->{hash}->{"_metadata \0"}; + if ( $meta_data and $meta_data =~ m~(.+)~is ) + { + $schema = $col_names = $1; + $schema =~ s~.*(.+).*~$1~is; + $col_names =~ s~.*(.+).*~$1~is; + } + } + $col_names ||= $meta->{col_names} || [ 'k', 'v' ]; + $col_names = [ split /,/, $col_names ] if ( ref $col_names ne 'ARRAY' ); + if ( $meta->{dbm_store_metadata} and not $meta->{hash}->{"_metadata \0"} ) + { + $schema or $schema = ''; + $meta->{hash}->{"_metadata \0"} = + "" + . "$schema" + . "" + . join( ",", @{$col_names} ) + . "" + . ""; + } + + $meta->{schema} = $schema; + $meta->{col_names} = $col_names; + } +} + +# you must define drop +# it is called from execute of a SQL DROP statement +# +sub drop ($$) +{ + my ( $self, $data ) = @_; + my $meta = $self->{meta}; + $meta->{hash} and untie %{ $meta->{hash} }; + $self->SUPER::drop($data); + # XXX extra_files + -f $meta->{f_fqbn} . $dirfext + and $meta->{f_ext} eq '.pag/r' + and unlink( $meta->{f_fqbn} . $dirfext ); + return 1; +} + +# you must define fetch_row, it is called on all fetches; +# it MUST return undef when no rows are left to fetch; +# checking for $ary[0] is specific to hashes so you'll +# probably need some other kind of check for nothing-left. +# as Janis might say: "undef's just another word for +# nothing left to fetch" :-) +# +sub fetch_row ($$) +{ + my ( $self, $data ) = @_; + my $meta = $self->{meta}; + # fetch with %each + # + my @ary = each %{ $meta->{hash} }; + $meta->{dbm_store_metadata} + and $ary[0] + and $ary[0] eq "_metadata \0" + and @ary = each %{ $meta->{hash} }; + + my ( $key, $val ) = @ary; + unless ($key) + { + delete $self->{row}; + return; + } + my @row = ( ref($val) eq 'ARRAY' ) ? ( $key, @$val ) : ( $key, $val ); + $self->{row} = @row ? \@row : undef; + return wantarray ? @row : \@row; +} + +# you must define push_row except insert_new_row and update_specific_row is defined +# it is called on inserts and updates as primitive +# +sub insert_new_row ($$$) +{ + my ( $self, $data, $row_aryref ) = @_; + my $meta = $self->{meta}; + my $ncols = scalar( @{ $meta->{col_names} } ); + my $nitems = scalar( @{$row_aryref} ); + $ncols == $nitems + or croak "You tried to insert $nitems, but table is created with $ncols columns"; + + my $key = shift @$row_aryref; + my $exists; + eval { $exists = exists( $meta->{hash}->{$key} ); }; + $exists and croak "Row with PK '$key' already exists"; + + $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row_aryref : $row_aryref->[0]; + + return 1; +} + +# this is where you grab the column names from a CREATE statement +# if you don't need to do that, it must be defined but can be empty +# +sub push_names ($$$) +{ + my ( $self, $data, $row_aryref ) = @_; + my $meta = $self->{meta}; + + # some sanity checks ... + my $ncols = scalar(@$row_aryref); + $ncols < 2 and croak "At least 2 columns are required for DBD::DBM tables ..."; + !$meta->{dbm_mldbm} + and $ncols > 2 + and croak "Without serializing with MLDBM only 2 columns are supported, you give $ncols"; + $meta->{col_names} = $row_aryref; + return unless $meta->{dbm_store_metadata}; + + my $stmt = $data->{sql_stmt}; + my $col_names = join( ',', @{$row_aryref} ); + my $schema = $data->{Database}->{Statement}; + $schema =~ s/^[^\(]+\((.+)\)$/$1/s; + $schema = $stmt->schema_str() if ( $stmt->can('schema_str') ); + $meta->{hash}->{"_metadata \0"} = + "" + . "$schema" + . "$col_names" + . ""; +} + +# fetch_one_row, delete_one_row, update_one_row +# are optimized for hash-style lookup without looping; +# if you don't need them, omit them, they're optional +# but, in that case you may need to define +# truncate() and seek(), see below +# +sub fetch_one_row ($$;$) +{ + my ( $self, $key_only, $key ) = @_; + my $meta = $self->{meta}; + $key_only and return $meta->{col_names}->[0]; + exists $meta->{hash}->{$key} or return; + my $val = $meta->{hash}->{$key}; + $val = ( ref($val) eq 'ARRAY' ) ? $val : [$val]; + my $row = [ $key, @$val ]; + return wantarray ? @{$row} : $row; +} + +sub delete_one_row ($$$) +{ + my ( $self, $data, $aryref ) = @_; + my $meta = $self->{meta}; + delete $meta->{hash}->{ $aryref->[0] }; +} + +sub update_one_row ($$$) +{ + my ( $self, $data, $aryref ) = @_; + my $meta = $self->{meta}; + my $key = shift @$aryref; + defined $key or return; + my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; + $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row : $row->[0]; +} + +sub update_specific_row ($$$$) +{ + my ( $self, $data, $aryref, $origary ) = @_; + my $meta = $self->{meta}; + my $key = shift @$origary; + my $newkey = shift @$aryref; + return unless ( defined $key ); + $key eq $newkey or delete $meta->{hash}->{$key}; + my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; + $meta->{hash}->{$newkey} = $meta->{dbm_mldbm} ? $row : $row->[0]; +} + +# you may not need to explicitly DESTROY the ::Table +# put cleanup code to run when the execute is done +# +sub DESTROY ($) +{ + my $self = shift; + my $meta = $self->{meta}; + $meta->{hash} and untie %{ $meta->{hash} }; + + $self->SUPER::DESTROY(); +} + +# truncate() and seek() must be defined to satisfy DBI::SQL::Nano +# *IF* you define the *_one_row methods above, truncate() and +# seek() can be empty or you can use them without actually +# truncating or seeking anything but if you don't define the +# *_one_row methods, you may need to define these + +# if you need to do something after a series of +# deletes or updates, you can put it in truncate() +# which is called at the end of executing +# +sub truncate ($$) +{ + # my ( $self, $data ) = @_; + return 1; +} + +# seek() is only needed if you use IO::File +# though it could be used for other non-file operations +# that you need to do before "writes" or truncate() +# +sub seek ($$$$) +{ + # my ( $self, $data, $pos, $whence ) = @_; + return 1; +} + +# Th, th, th, that's all folks! See DBD::File and DBD::CSV for other +# examples of creating pure perl DBDs. I hope this helped. +# Now it's time to go forth and create your own DBD! +# Remember to check in with dbi-dev@perl.org before you get too far. +# We may be able to make suggestions or point you to other related +# projects. + +1; +__END__ + +=pod + +=head1 NAME + +DBD::DBM - a DBI driver for DBM & MLDBM files + +=head1 SYNOPSIS + + use DBI; + $dbh = DBI->connect('dbi:DBM:'); # defaults to SDBM_File + $dbh = DBI->connect('DBI:DBM(RaiseError=1):'); # defaults to SDBM_File + $dbh = DBI->connect('dbi:DBM:dbm_type=DB_File'); # defaults to DB_File + $dbh = DBI->connect('dbi:DBM:dbm_mldbm=Storable'); # MLDBM with SDBM_File + + # or + $dbh = DBI->connect('dbi:DBM:', undef, undef); + $dbh = DBI->connect('dbi:DBM:', undef, undef, { + f_ext => '.db/r', + f_dir => '/path/to/dbfiles/', + f_lockfile => '.lck', + dbm_type => 'BerkeleyDB', + dbm_mldbm => 'FreezeThaw', + dbm_store_metadata => 1, + dbm_berkeley_flags => { + '-Cachesize' => 1000, # set a ::Hash flag + }, + }); + +and other variations on connect() as shown in the L docs, +L and L +shown below. + +Use standard DBI prepare, execute, fetch, placeholders, etc., +see L for an example. + +=head1 DESCRIPTION + +DBD::DBM is a database management system that works right out of the +box. If you have a standard installation of Perl and DBI you can +begin creating, accessing, and modifying simple database tables +without any further modules. You can add other modules (e.g., +SQL::Statement, DB_File etc) for improved functionality. + +The module uses a DBM file storage layer. DBM file storage is common on +many platforms and files can be created with it in many programming +languages using different APIs. That means, in addition to creating +files with DBI/SQL, you can also use DBI/SQL to access and modify files +created by other DBM modules and programs and vice versa. B that +in those cases it might be necessary to use a common subset of the +provided features. + +DBM files are stored in binary format optimized for quick retrieval +when using a key field. That optimization can be used advantageously +to make DBD::DBM SQL operations that use key fields very fast. There +are several different "flavors" of DBM which use different storage +formats supported by perl modules such as SDBM_File and MLDBM. This +module supports all of the flavors that perl supports and, when used +with MLDBM, supports tables with any number of columns and insertion +of Perl objects into tables. + +DBD::DBM has been tested with the following DBM types: SDBM_File, +NDBM_File, ODBM_File, GDBM_File, DB_File, BerkeleyDB. Each type was +tested both with and without MLDBM and with the Data::Dumper, +Storable, FreezeThaw, YAML and JSON serializers using the DBI::SQL::Nano +or the SQL::Statement engines. + +=head1 QUICK START + +DBD::DBM operates like all other DBD drivers - it's basic syntax and +operation is specified by DBI. If you're not familiar with DBI, you should +start by reading L and the documents it points to and then come back +and read this file. If you are familiar with DBI, you already know most of +what you need to know to operate this module. Just jump in and create a +test script something like the one shown below. + +You should be aware that there are several options for the SQL engine +underlying DBD::DBM, see L. There are also many +options for DBM support, see especially the section on L. + +But here's a sample to get you started. + + use DBI; + my $dbh = DBI->connect('dbi:DBM:'); + $dbh->{RaiseError} = 1; + for my $sql( split /;\n+/," + CREATE TABLE user ( user_name TEXT, phone TEXT ); + INSERT INTO user VALUES ('Fred Bloggs','233-7777'); + INSERT INTO user VALUES ('Sanjay Patel','777-3333'); + INSERT INTO user VALUES ('Junk','xxx-xxxx'); + DELETE FROM user WHERE user_name = 'Junk'; + UPDATE user SET phone = '999-4444' WHERE user_name = 'Sanjay Patel'; + SELECT * FROM user + "){ + my $sth = $dbh->prepare($sql); + $sth->execute; + $sth->dump_results if $sth->{NUM_OF_FIELDS}; + } + $dbh->disconnect; + +=head1 USAGE + +This section will explain some usage cases in more detail. To get an +overview about the available attributes, see L. + +=head2 Specifying Files and Directories + +DBD::DBM will automatically supply an appropriate file extension for the +type of DBM you are using. For example, if you use SDBM_File, a table +called "fruit" will be stored in two files called "fruit.pag" and +"fruit.dir". You should B specify the file extensions in your SQL +statements. + +DBD::DBM recognizes following default extensions for following types: + +=over 4 + +=item .pag/r + +Chosen for dbm_type C<< SDBM_File >>, C<< ODBM_File >> and C<< NDBM_File >> +when an implementation is detected which wraps C<< -ldbm >> for +C<< NDBM_File >> (e.g. Solaris, AIX, ...). + +For those types, the C<< .dir >> extension is recognized, too (for being +deleted when dropping a table). + +=item .db/r + +Chosen for dbm_type C<< NDBM_File >> when an implementation is detected +which wraps BerkeleyDB 1.x for C<< NDBM_File >> (typically BSD's, Darwin). + +=back + +C<< GDBM_File >>, C<< DB_File >> and C<< BerkeleyDB >> don't usually +use a file extension. + +If your DBM type uses an extension other than one of the recognized +types of extensions, you should set the I attribute to the +extension B file a bug report as described in DBI with the name +of the implementation and extension so we can add it to DBD::DBM. +Thanks in advance for that :-). + + $dbh = DBI->connect('dbi:DBM:f_ext=.db'); # .db extension is used + $dbh = DBI->connect('dbi:DBM:f_ext='); # no extension is used + + # or + $dbh->{f_ext}='.db'; # global setting + $dbh->{f_meta}->{'qux'}->{f_ext}='.db'; # setting for table 'qux' + +By default files are assumed to be in the current working directory. +To use other directories specify the I attribute in either the +connect string or by setting the database handle attribute. + +For example, this will look for the file /foo/bar/fruit (or +/foo/bar/fruit.pag for DBM types that use that extension) + + my $dbh = DBI->connect('dbi:DBM:f_dir=/foo/bar'); + # and this will too: + my $dbh = DBI->connect('dbi:DBM:'); + $dbh->{f_dir} = '/foo/bar'; + # but this is recommended + my $dbh = DBI->connect('dbi:DBM:', undef, undef, { f_dir => '/foo/bar' } ); + + # now you can do + my $ary = $dbh->selectall_arrayref(q{ SELECT x FROM fruit }); + +You can also use delimited identifiers to specify paths directly in SQL +statements. This looks in the same place as the two examples above but +without setting I: + + my $dbh = DBI->connect('dbi:DBM:'); + my $ary = $dbh->selectall_arrayref(q{ + SELECT x FROM "/foo/bar/fruit" + }); + +You can also tell DBD::DBM to use a specified path for a specific table: + + $dbh->{dbm_tables}->{f}->{file} = q(/foo/bar/fruit); + +Please be aware that you cannot specify this during connection. + +If you have SQL::Statement installed, you can use table aliases: + + my $dbh = DBI->connect('dbi:DBM:'); + my $ary = $dbh->selectall_arrayref(q{ + SELECT f.x FROM "/foo/bar/fruit" AS f + }); + +See the L for using DROP on tables. + +=head2 Table locking and flock() + +Table locking is accomplished using a lockfile which has the same +basename as the table's file but with the file extension '.lck' (or a +lockfile extension that you supply, see below). This lock file is +created with the table during a CREATE and removed during a DROP. +Every time the table itself is opened, the lockfile is flocked(). For +SELECT, this is a shared lock. For all other operations, it is an +exclusive lock (except when you specify something different using the +I attribute). + +Since the locking depends on flock(), it only works on operating +systems that support flock(). In cases where flock() is not +implemented, DBD::DBM will simply behave as if the flock() had +occurred although no actual locking will happen. Read the +documentation for flock() for more information. + +Even on those systems that do support flock(), locking is only +advisory - as is always the case with flock(). This means that if +another program tries to access the table file while DBD::DBM has the +table locked, that other program will *succeed* at opening unless +it is also using flock on the '.lck' file. As a result DBD::DBM's +locking only really applies to other programs using DBD::DBM or other +program written to cooperate with DBD::DBM locking. + +=head2 Specifying the DBM type + +Each "flavor" of DBM stores its files in a different format and has +different capabilities and limitations. See L for a +comparison of DBM types. + +By default, DBD::DBM uses the C<< SDBM_File >> type of storage since +C<< SDBM_File >> comes with Perl itself. If you have other types of +DBM storage available, you can use any of them with DBD::DBM. It is +strongly recommended to use at least C<< DB_File >>, because C<< +SDBM_File >> has quirks and limitations and C<< ODBM_file >>, C<< +NDBM_File >> and C<< GDBM_File >> are not always available. + +You can specify the DBM type using the I attribute which can +be set in the connection string or with C<< $dbh->{dbm_type} >> and +C<< $dbh->{f_meta}->{$table_name}->{type} >> for per-table settings in +cases where a single script is accessing more than one kind of DBM +file. + +In the connection string, just set C<< dbm_type=TYPENAME >> where +C<< TYPENAME >> is any DBM type such as GDBM_File, DB_File, etc. Do I +use MLDBM as your I as that is set differently, see below. + + my $dbh=DBI->connect('dbi:DBM:'); # uses the default SDBM_File + my $dbh=DBI->connect('dbi:DBM:dbm_type=GDBM_File'); # uses the GDBM_File + + # You can also use $dbh->{dbm_type} to set the DBM type for the connection: + $dbh->{dbm_type} = 'DB_File'; # set the global DBM type + print $dbh->{dbm_type}; # display the global DBM type + +If you have several tables in your script that use different DBM +types, you can use the $dbh->{dbm_tables} hash to store different +settings for the various tables. You can even use this to perform +joins on files that have completely different storage mechanisms. + + # sets global default of GDBM_File + my $dbh->('dbi:DBM:type=GDBM_File'); + + # overrides the global setting, but only for the tables called + # I and I + my $dbh->{f_meta}->{foo}->{dbm_type} = 'DB_File'; + my $dbh->{f_meta}->{bar}->{dbm_type} = 'BerkeleyDB'; + + # prints the dbm_type for the table "foo" + print $dbh->{f_meta}->{foo}->{dbm_type}; + +B that you must change the I of a table before you access +it for first time. + +=head2 Adding multi-column support with MLDBM + +Most of the DBM types only support two columns and even if it would +support more, DBD::DBM would only use two. However a CPAN module +called MLDBM overcomes this limitation by allowing more than two +columns. MLDBM does this by serializing the data - basically it puts +a reference to an array into the second column. It can also put almost +any kind of Perl object or even B into columns. + +If you want more than two columns, you B install MLDBM. It's available +for many platforms and is easy to install. + +MLDBM is by default distributed with three serializers - Data::Dumper, +Storable, and FreezeThaw. Data::Dumper is the default and Storable is the +fastest. MLDBM can also make use of user-defined serialization methods or +other serialization modules (e.g. L or +L. You select the serializer using the +I attribute. + +Some examples: + + $dbh=DBI->connect('dbi:DBM:dbm_mldbm=Storable'); # use MLDBM with Storable + $dbh=DBI->connect( + 'dbi:DBM:dbm_mldbm=MySerializer' # use MLDBM with a user defined module + ); + $dbh=DBI->connect('dbi::dbm:', undef, + undef, { dbm_mldbm => 'YAML' }); # use 3rd party serializer + $dbh->{dbm_mldbm} = 'YAML'; # same as above + print $dbh->{dbm_mldbm} # show the MLDBM serializer + $dbh->{f_meta}->{foo}->{dbm_mldbm}='Data::Dumper'; # set Data::Dumper for table "foo" + print $dbh->{f_meta}->{foo}->{mldbm}; # show serializer for table "foo" + +MLDBM works on top of other DBM modules so you can also set a DBM type +along with setting dbm_mldbm. The examples above would default to using +SDBM_File with MLDBM. If you wanted GDBM_File instead, here's how: + + # uses DB_File with MLDBM and Storable + $dbh = DBI->connect('dbi:DBM:', undef, undef, { + dbm_type => 'DB_File', + dbm_mldbm => 'Storable', + }); + +SDBM_File, the default I is quite limited, so if you are going to +use MLDBM, you should probably use a different type, see L. + +See below for some L about MLDBM. + +=head2 Support for Berkeley DB + +The Berkeley DB storage type is supported through two different Perl +modules - DB_File (which supports only features in old versions of Berkeley +DB) and BerkeleyDB (which supports all versions). DBD::DBM supports +specifying either "DB_File" or "BerkeleyDB" as a I, with or +without MLDBM support. + +The "BerkeleyDB" dbm_type is experimental and it's interface is likely to +change. It currently defaults to BerkeleyDB::Hash and does not currently +support ::Btree or ::Recno. + +With BerkeleyDB, you can specify initialization flags by setting them in +your script like this: + + use BerkeleyDB; + my $env = new BerkeleyDB::Env -Home => $dir; # and/or other Env flags + $dbh = DBI->connect('dbi:DBM:', undef, undef, { + dbm_type => 'BerkeleyDB', + dbm_mldbm => 'Storable', + dbm_berkeley_flags => { + 'DB_CREATE' => DB_CREATE, # pass in constants + 'DB_RDONLY' => DB_RDONLY, # pass in constants + '-Cachesize' => 1000, # set a ::Hash flag + '-Env' => $env, # pass in an environment + }, + }); + +Do I set the -Flags or -Filename flags as those are determined and +overwritten by the SQL (e.g. -Flags => DB_RDONLY is set automatically +when you issue a SELECT statement). + +Time has not permitted us to provide support in this release of DBD::DBM +for further Berkeley DB features such as transactions, concurrency, +locking, etc. We will be working on these in the future and would value +suggestions, patches, etc. + +See L and L for further details. + +=head2 Optimizing the use of key fields + +Most "flavors" of DBM have only two physical columns (but can contain +multiple logical columns as explained above in +L). They work similarly to a +Perl hash with the first column serving as the key. Like a Perl hash, DBM +files permit you to do quick lookups by specifying the key and thus avoid +looping through all records (supported by DBI::SQL::Nano only). Also like +a Perl hash, the keys must be unique. It is impossible to create two +records with the same key. To put this more simply and in SQL terms, +the key column functions as the I or UNIQUE INDEX. + +In DBD::DBM, you can take advantage of the speed of keyed lookups by using +DBI::SQL::Nano and a WHERE clause with a single equal comparison on the key +field. For example, the following SQL statements are optimized for keyed +lookup: + + CREATE TABLE user ( user_name TEXT, phone TEXT); + INSERT INTO user VALUES ('Fred Bloggs','233-7777'); + # ... many more inserts + SELECT phone FROM user WHERE user_name='Fred Bloggs'; + +The "user_name" column is the key column since it is the first +column. The SELECT statement uses the key column in a single equal +comparison - "user_name='Fred Bloggs'" - so the search will find it +very quickly without having to loop through all the names which were +inserted into the table. + +In contrast, these searches on the same table are not optimized: + + 1. SELECT phone FROM user WHERE user_name < 'Fred'; + 2. SELECT user_name FROM user WHERE phone = '233-7777'; + +In #1, the operation uses a less-than (<) comparison rather than an equals +comparison, so it will not be optimized for key searching. In #2, the key +field "user_name" is not specified in the WHERE clause, and therefore the +search will need to loop through all rows to find the requested row(s). + +B that the underlying DBM storage needs to loop over all I +pairs when the optimized fetch is used. SQL::Statement has a massively +improved where clause evaluation which costs around 15% of the evaluation +in DBI::SQL::Nano - combined with the loop in the DBM storage the speed +improvement isn't so impressive. + +Even if lookups are faster by around 50%, DBI::SQL::Nano and +SQL::Statement can benefit from the key field optimizations on +updating and deleting rows - and here the improved where clause +evaluation of SQL::Statement might beat DBI::SQL::Nano every time the +where clause contains not only the key field (or more than one). + +=head2 Supported SQL syntax + +DBD::DBM uses a subset of SQL. The robustness of that subset depends on +what other modules you have installed. Both options support basic SQL +operations including CREATE TABLE, DROP TABLE, INSERT, DELETE, UPDATE, and +SELECT. + +B