Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
#!/usr/bin/perl -w # vim: set sw=4 ts=4 tw=78 et si: # # mkdir_heute - choose or make a dir for 'heute' (today) # # This script scans a basedir (~/A) for directories named YYYY/MM/DD # where YYYY, MM and DD are numbers corresponding to a year, month, da +y of # month and prints them on STDERR. You may choose a directory from the + list # or a new directory which will be created and named after the current + day. # # The script returns the choosen directory on STDOUT and may be used i +n a # shell alias like this: # # alias cdheute='cd `mkdir_heute`' # # so that you may say 'cdheute' on the command line and your working d +irectory # will be changed to the choosen directory. # use strict; use warnings; use Term::ReadKey; package Directory::Organize; use strict; use warnings; use version; our $VERSION = qv('0.8'); sub new { my $self = shift; my $type = ref($self) || $self; $self = bless {}, $type; $self->{basedir} = shift; $self->set_today(); return $self; } # new(); sub get_descriptions { my $self = shift; if (!exists $self->{descriptions}) { $self->_read_descriptions(); } return wantarray ? @{$self->{descriptions}} : $self->{descriptions +}; } # get_descriptions() sub new_dir { my ($self,$descr) = @_; my $daydir = sprintf "%4.4d/%2.2d/%2.2d", $self->{tyear}, $self->{ +tmonth} , $self->{tday}; my $dirprefix = qq($self->{basedir}/$daydir); my $suffix = q(); if (-d $dirprefix) { $suffix = 'a'; while (-d qq($dirprefix$suffix)) { $suffix++; } } my $path = qq($dirprefix$suffix/); my $dir = q(); while ($path =~ s{^([^/]*)/}{}) { if ($1) { $dir .= $1; (-d $dir) || mkdir($dir,0777) || return undef; $dir .= '/'; } else { $dir = '/' unless ($dir); } } my $project = qq($dirprefix$suffix/.project); if ($descr and open (my $PROJ,'>',$project)) { print $PROJ qq($descr\n); close $PROJ; } return qq($dirprefix$suffix); } # new_dir() sub set_pattern { my ($self,$pattern) = @_; if ($pattern && defined $self->{pattern} && $self->{pattern} eq $pattern) { return; } if (!$pattern and !defined $self->{pattern}) { return; } delete $self->{descriptions}; if (!$pattern) { delete $self->{pattern}; } else { $self->{pattern} = $pattern; } } # set_pattern() sub set_time_constraint { my ($self,$op,$year,$month,$day) = @_; if (defined $year and $op =~ /^[=<>]$/) { $self->{tc}->{op} = $op; $self->{tc}->{year} = sprintf "%04d",$year; $self->{tc}->{month} = sprintf "%02d",$month if (defined $m +onth); $self->{tc}->{day} = sprintf "%02d",$day if (defined $d +ay); delete $self->{descriptions}; } else { if ($self->{tc}) { delete $self->{descriptions}; delete $self->{tc}; } } } # set_time_constraint() sub set_today { my $self = shift; my ($tday,$tmonth,$tyear) = @_; if (defined $tyear) { $self->{tday} = $tday; $self->{tmonth} = $tmonth; $self->{tyear} = $tyear; return; } my ($day,$month,$year) = (localtime)[3,4,5]; $year += 1900; $month += 1; if (defined $tmonth) { $self->{tday} = $tday; $self->{tmonth} = $tmonth; $self->{tyear} = $year; } elsif (defined $tday) { $self->{tday} = $tday; $self->{tmonth} = $month; $self->{tyear} = $year; } else { $self->{tday} = $day; $self->{tmonth} = $month; $self->{tyear} = $year; } return; } # set_today() sub _not_in_tc { my ($self,$year,$month,$day) = @_; my ($tc,$tc_date,$date,$result); $tc = $self->{tc}; if (defined $day) { if (defined $tc->{day}) { $tc_date = $tc->{year} . $tc->{month} . $tc->{day}; $date = $year . $month . substr($day,0,2); } elsif (defined $tc->{month}) { $tc_date = $tc->{year} . $tc->{month}; $date = $year . $month; } else { $tc_date = $tc->{year}; $date = $year; } } elsif (defined $month) { if (defined $tc->{day}) { $tc_date = $tc->{year} . $tc->{month}; $date = $year . $month; $date++ if ('>' eq $tc->{op}); $date-- if ('<' eq $tc->{op}); } elsif (defined $tc->{month}) { $tc_date = $tc->{year} . $tc->{month}; $date = $year . $month; } else { $tc_date = $tc->{year}; $date = $year; } } else { if (defined $tc->{month}) { $tc_date = $tc->{year}; $date = $year; $date++ if ('>' eq $tc->{op}); $date-- if ('<' eq $tc->{op}); } else { $tc_date = $tc->{year}; $date = $year; } } $result = '<' eq $tc->{op} ? $date ge $tc_date : '>' eq $tc->{op} ? $date le $tc_date : $date ne $tc_date ; return $result; } # _not_in_tc() sub _read_descriptions { my $self = shift; my $base = $self->{basedir}; $self->{descriptions} = []; if (opendir my $BASEDIR, $base) { my %dirs = map { ("$_" => {}) } grep { m/^ # match names with \d{4} # four digits $ # exactly /x } readdir( $BASEDIR ); closedir $BASEDIR; YEAR: for my $year (reverse sort keys %dirs) { next if ($self->{tc} && $self->_not_in_tc($year)); if (opendir my $YEARDIR, qq($base/$year)) { my %mdirs = map { ("$_" => {}) } grep { m/^ # match names with \d{2} # two digits $ # exactly /x } readdir( $YEARDIR ); $dirs{$year} = \%mdirs; closedir $YEARDIR; } MONTH: for my $month (reverse sort keys %{$dirs{$year}}) { next if ($self->{tc} && $self->_not_in_tc($year,$month +)); if (opendir my $MONTHDIR, qq($base/$year/$month)) { my %ddirs = map { ("$_" => {}) } grep { m/^ # match names that sta +rt \d{2} # with two digits /x && -d qq($base/$year/$month/$_) } readdir($MONTHDIR); $dirs{$year}->{$month} = \%ddirs; close $MONTHDIR; } DAY: for my $day (reverse sort keys %{$dirs{$year}->{$month +}}) { next if ($self->{tc} && $self->_not_in_tc($year,$month,$day)); my $path = qq($year/$month/$day); my $desc = ""; if (-f qq($base/$path/.project) and open my $PROJECT, '<', qq($base/$path/.pro +ject)) { $desc = <$PROJECT>; close $PROJECT; chomp $desc; } if ($self->{pattern} && $desc !~ /$self->{pattern} +/i) { next; } push @{$self->{descriptions}}, [ $path, $desc ]; } } } } return; } # _read_descriptions(); 1; package main; $|++; my %params; init_params(\%params); print choosedir(\%params); #----- only subs from now on ----- sub init_params { my ($params) = @_; my ($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize("STDOUT" +); $params->{basedir} = "$ENV{HOME}/A"; $params->{listlines} = defined $hchar ? $hchar - 4 : 21; return $params; } # init_params() sub makedir { my $path = shift; my $dir = ''; $path =~ s{^(.*[^/])$}{$1/}; # provide a sentinel while ($path =~ s{^([^/]*)/}{}) { if ($1) { $dir .= $1; (-d $dir) || mkdir($dir,0777) || return 0; $dir .= '/'; } else { $dir = '/' unless ($dir); } } return 1; } # makedir() sub choosedir { my ($params) = @_; my $basedir = $params->{basedir}; my $listlines = $params->{listlines}; my $firstline = 0; my $do = Directory::Organize->new($basedir); NEW_DESCRIPTIONS: while (1) { my @directories = $do->get_descriptions(); my $lastline = scalar(@directories) - $listlines - 1; SHOW_DESCRIPTIONS: while (1) { show_dirs(\@directories,$listlines,$firstline); # let the user choose a directory my $input = ''; while (1) { my $project_text = ''; $input = <STDIN>; chomp $input; if ($input =~ /^\d+$/) { return $basedir . '/' . $directories[$input]->[0] if ($input < scalar @directories); } elsif ($input =~ /^f(irst)?$/i) { $firstline = 0; next SHOW_DESCRIPTIONS; } elsif ($input =~ /^l(ast)?$/i) { $firstline = $lastline; next SHOW_DESCRIPTIONS; } elsif ($input =~ /^n(ext)?$/i) { $firstline += $listlines; $firstline = $lastline if ($firstline > $lastline) +; next SHOW_DESCRIPTIONS; } elsif ($input =~ /^p(revious)?$/i) { $firstline -= $listlines; $firstline = 0 if ($firstline < 0); next SHOW_DESCRIPTIONS; } elsif ($input =~ /^\/(.*)$/i) { $do->set_pattern($1); $firstline = 0; next NEW_DESCRIPTIONS; } elsif ($input =~ m{^d \s* (?: ([=<>]) # operator \s* (\d{4}) # year -? (\d\d)? # month -? (\d\d)? # day )? }ix) { $do->set_time_constraint($1,$2,$3,$4); $firstline = 0; next NEW_DESCRIPTIONS; } elsif ($input =~ /^(\.|q(uit)?)$/i) { return '.'; } elsif ($input =~ /^\+(.*)$/) { if ($1) { $project_text = $1; $project_text =~ s/^\s+//; $project_text =~ s/\s+$//; return $do->new_dir($project_text); } next SHOW_DESCRIPTIONS; } } } # SHOW_DESCRIPTIONS } # NEW_DESCRIPTIONS } # choosedir() sub show_dirs { my ($dirs,$listlines,$firstline) = @_; my $i = 0; foreach my $dir (@$dirs) { printf STDERR "%-7s: %-12s: %s\n", $i, $dir->[0], $dir->[1] if ($i >= $firstline); last if ($i - $firstline >= $listlines); $i++; } print STDERR "+(plus): new directory (add description after '+')\n +"; print STDERR "q : current directory\n"; } # show_dirs() __END__ =head1 NAME mkdir_heute - create and find directories interactive =head1 VERSION This documentation refers to Directory::Organize version 0.8 =head1 USAGE This script scans a basedir (~/A) for directories named YYYY/MM/DD where YYYY, MM and DD are numbers corresponding to a year, month, day +of month and prints them on STDERR. You may =over 4 =item * choose a directory from the list with it's number =item * choose the current directory with 'q' or '.' =item * advance to the next or last page with 'n' or 'l' =item * return to the previous or first page with 'p' or 'f' =item * constrain the shown directories with '/' and a pattern =item * constrain the creation date of the directories with 'd' followed by '= +', '<' or '>' and a date (eg. 2009, 2009-04 or 2009-04-24) =item * create a new directory with '+' and a description for it =back The script returns the choosen directory on STDOUT and may be used in +a shell alias like this: alias cdheute='cd `mkdir_heute`' so that you may say 'cdheute' on the command line and your working dir +ectory will be changed to the choosen directory. =head1 AUTHOR Mathias Weidner =head1 LICENCE AND COPYRIGHT Copyright (c) 2009 Mathias Weidner (mathias@weidner.in-bad-schmiedeber +g.de). All rights reserved. This module is free software; you can redistribute and/or modify it under the same terms as Perl itself. See L<perlartistic>. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

In reply to mkdir_heute by mamawe

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others exploiting the Monastery: (4)
As of 2024-03-29 00:25 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found